source: tol/toltcl/generic/tolaccess.cpp @ b0f6382

1941-docker-image-to-testdevel
Last change on this file since b0f6382 was b0f6382, checked in by Jorge Pérez <josp.jorge@…>, 15 years ago

refs #1449, including name of struct or class if the object is a Set or NameBlock, for (3.2)

git-svn-id: ​https://www.tol-project.org/svn/tolp/trunk@4194 be4846ae-f051-483a-831f-b64e7d08527f
  • Property mode set to 100644
File size: 77.2 KB
Line 
1/* tolaccess.cpp: This file implements an interface between object in tol
2                  and "objects" in tclThis file define a set of utils
3                  functions.
4                  GNU/tolTcl Library
5
6   Copyright (C) 2001, 2002, 2003 - Bayes Decisión, SL
7
8   This program is free software; you can redistribute it and/or modify
9   it under the terms of the GNU General Public License as published by
10   the Free Software Foundation; either version 2, or (at your option)
11   any later version.
12
13   This program is distributed in the hope that it will be useful,
14   but WITHOUT ANY WARRANTY; without even the implied warranty of
15   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
16   GNU General Public License for more details.
17
18   You should have received a copy of the GNU General Public License
19   along with this program; if not, write to the Free Software
20   Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
21   USA.
22 */
23
24#include <ctype.h>
25
26#if defined(_MSC_VER)
27#  include <win_tolinc.h>
28#endif
29
30#include <tol/tol_init.h>
31#include <tol/tol_version_def.h>
32#include <tol/tol_bcommon.h>
33#include <tol/tol_bstruct.h>
34#include <tol/tol_blanguag.h>
35#include <tol/tol_bmatgra.h>
36#include <tol/tol_bvmatgra.h>
37#include <tol/tol_bnameblock.h>
38#include <tol/tol_bspfun.h>
39#include <tol/tol_bcodgra.h>
40#include <tol/tol_bsetgra.h>
41#include <tol/tol_btsrgra.h>
42#include <tol/tol_btxtgra.h>
43#include <tol/tol_bmethodhook.h>
44
45#include <toltclInt.h>
46#include <tt_pool.h>
47
48
49/*
50 * if SyntaxObject has IsFile implemented, uncomment the following
51 * define:
52 */
53
54#define ISFILE_IMPLEMENTED
55
56typedef void (* getmethod)( const BSyntaxObject *, BText & );
57typedef int  (* checkmethod)( const BSyntaxObject * );
58
59static
60int QuickSort( Tcl_Interp * interp, Tcl_Obj * list );
61
62inline
63char * skipWhite(char * pch)
64{
65  while (*pch && isspace(*pch))
66    ++pch;
67  return pch;
68}
69
70static
71BText GetObjectName(const BSyntaxObject * so)
72{
73  // antes estaba FullName pero salian cosas como:
74  // estim::cycler::_.sampler::_.buildWorkSpace
75  return so->HasName() ? so->Name() : so->LocalName();
76}
77
78static
79void GetName( const BSyntaxObject * so, BText & res )
80{
81  // antes estaba FullName pero salian cosas como:
82  // estim::cycler::_.sampler::_.buildWorkSpace
83  res = so->Name();
84}
85
86static
87void GetFullName( const BSyntaxObject * so, BText & res )
88{
89  res = so->FullName();
90}
91
92static
93void GetIdentify( const BSyntaxObject * so, BText & res )
94{
95  res = so->Identify();
96}
97
98static
99void GetPath( const BSyntaxObject * so, BText & res )
100{
101  res = so->TolPath();
102}
103
104static
105int
106ExcludeAnything( const BSyntaxObject * so )
107{
108  return so != GraAnything();
109}
110
111static
112int HasNoSource( const BSyntaxObject * so )
113{
114  return !so->Source();
115}
116
117static
118int BList2TclList( Tcl_Interp * interp,
119                   BList * blist, Tcl_Obj * tcl_list,
120                   getmethod m, checkmethod accept = NULL)
121{
122  char * str;
123  Tcl_Obj * name;
124  Tcl_DString dstr;
125  BText tmp;
126
127  while(blist)
128  {
129    BSyntaxObject* so = (BSyntaxObject*)Car(blist);
130    if(!accept || (*accept)(so))
131    {
132      (*m)(so,tmp);
133      str = Tcl_ExternalToUtfDString(NULL,tmp,-1,&dstr);
134      name = Tcl_NewStringObj(str,-1);
135      Tcl_DStringFree(&dstr);
136      if ( Tcl_ListObjAppendElement(interp, tcl_list, name) != TCL_OK ) {
137        Tcl_DecrRefCount(name);
138        return TCL_ERROR;
139      }
140    }
141    blist = Cdr(blist);
142  }
143  return TCL_OK;
144}
145
146/*
147 * Fill in obj_result the result of avaluating in TOL the given
148 * string.
149 *
150 */
151
152/* cdr of console_stack point to first item */
153static BList console_stack;
154// Read only stack
155static BList console_stack_hidden;
156
157static
158void my_concat(BList* head, BList* tail)
159{
160  if (head->Cdr()) {
161    my_concat(head->Cdr(), tail);
162  } else {
163    head->PutCdr(tail);
164  }
165}
166
167int Tol_EvalExpr (Tcl_Obj * obj_expr, int hidden, Tcl_Obj * obj_result)
168{
169  BList * tol_result;
170  Tcl_DString dstr;
171  char * expr;
172 
173  Tcl_DStringInit(&dstr);
174  expr = Tcl_UtfToExternalDString(NULL,Tcl_GetString(obj_expr),-1,&dstr);
175  tol_result = MultyEvaluate(expr);
176  Tcl_DStringFree(&dstr);
177  if(tol_result) {
178    my_concat(hidden?&console_stack_hidden:&console_stack, tol_result);
179  }
180  /*  Tcl_AppendStringsToObj(obj_result,
181      "couldn't evaluate tol expresion \"",
182      Tcl_GetString(obj_expr), "\"", NULL);
183      return TCL_ERROR;*/
184  return TCL_OK;
185}
186
187int Tol_GetStructure( Tcl_Interp * interp, Tcl_Obj * name, Tcl_Obj * obj_result )
188{
189  Tcl_DString dstr;
190  BStruct * structure;
191  BStruct * substruct;
192
193  Tcl_DStringInit( &dstr );
194  Tcl_UtfToExternalDString( NULL, Tcl_GetString(name), -1, &dstr );
195  if ( Tcl_DStringLength( &dstr ) &&
196       (structure = FindStruct(Tcl_DStringValue(&dstr)))) {
197   
198    Tcl_Obj * tmp[2];
199    Tcl_Obj * info[2];
200    Tcl_Obj ** fields;
201    BText btxt;
202    int nfields;
203   
204    nfields = structure->Size();
205    fields = (Tcl_Obj**)Tcl_Alloc( sizeof(Tcl_Obj*) * nfields );
206    for ( int i = 0; i < nfields; i++ ) {
207      BField & field = (*structure)[i];
208      btxt = field.Name();
209      Tcl_DStringFree(&dstr);
210      Tcl_ExternalToUtfDString( NULL, btxt, -1, &dstr );
211      info[0] = Tcl_NewStringObj(Tcl_DStringValue(&dstr), -1);
212      Tcl_DStringFree( &dstr );
213      if ( (substruct = field.Struct()) ) {
214        btxt = substruct->Name();
215        Tcl_ExternalToUtfDString( NULL, btxt, -1, &dstr );
216        tmp[0] = Tcl_NewStringObj( "STRUCT", 6 );
217        tmp[1] = Tcl_NewStringObj( Tcl_DStringValue(&dstr), -1);
218        info[1] = Tcl_NewListObj( 2, tmp );
219      } else if ( field.Grammar() ) {
220        btxt = field.Grammar()->Name();
221        Tcl_ExternalToUtfDString( NULL, btxt, -1, &dstr );
222        info[1] = Tcl_NewStringObj(Tcl_DStringValue(&dstr), -1);
223      }
224      fields[i] = Tcl_NewListObj(2,info);
225    }
226    Tcl_SetListObj( obj_result, nfields, fields );
227    Tcl_Free( (char*)fields );
228  }
229  return TCL_OK;
230}
231
232BSet* ContainerGetSet(const BSyntaxObject *container)
233{
234  if (container) {
235    if (container->Grammar()==GraSet())
236      return &(((BUserSet*)container)->Contens());
237    else if (container->Grammar()==GraNameBlock())
238      return &(((BUserNameBlock*)container)->Contens().Set());
239  }
240  return NULL;
241}
242 
243/*
244 * Return the path of a set if it is a file, trigger an error in other case
245 *
246 */
247
248int Tol_GetSetPath( Tcl_Interp * interp, Tcl_Obj * name, Tcl_Obj * obj_result )
249{
250  Tcl_DString uniBuffer;
251  const BSyntaxObject * syn;
252
253 /* if name contains spaces the we should try it first as a string */
254  Tcl_DStringInit(&uniBuffer);
255  Tcl_UtfToExternalDString(NULL,Tcl_GetString(name),-1,&uniBuffer);
256  BText fname(Tcl_DStringValue(&uniBuffer));
257  syn = (BSyntaxObject*)BSetFromFile::FindCompiled(fname);
258  Tcl_DStringFree(&uniBuffer);
259  if (!syn) {
260    syn = Tol_ResolveObject(interp, name, obj_result);
261  }
262  if ( !syn )
263    return TCL_ERROR;
264  BSet *ptrSet = ContainerGetSet(syn);
265  if ( ptrSet->SubType() >= BSet::MODFile && ptrSet->SubType() <= BSet::BMIFile ) {
266    Tcl_DString dstr;
267    BText path( syn->TolPath() );
268
269    Tcl_DStringInit( &dstr );
270    Tcl_ExternalToUtfDString(NULL,path,-1,&dstr);
271    Tcl_SetStringObj( obj_result, Tcl_DStringValue(&dstr), -1 );
272    return TCL_OK;
273  } else {
274    Tcl_AppendStringsToObj( obj_result, Tcl_GetString(name),
275                            " is not a valid file object", NULL );
276    return TCL_ERROR;
277  }
278}
279
280/*
281 * Fill in obj_result the content of the given tol object's names. The
282 * object are searched in the console's stack.
283 *
284 * Return:
285 *
286 *   {GRAMMAR NAME CONTENT PATH DESCRIPTION ISFILE [Has SubSet? SUBTYPE STRUCTURE]}
287 */
288
289int Tol_ListStack(Tcl_Interp * interp,int objc,Tcl_Obj *CONST objv[],
290                  Tcl_Obj * obj_result)
291{
292  BSyntaxObject * so;
293  BText btxt;
294  Tcl_DString dstr;
295  BList * tol_item;
296  Tcl_Obj * robjv[9];
297  int robjc;
298  Tcl_Obj * tcl_item;
299  int tcl_result;
300  BSet * ptrSet = 0;
301  int tmpCard;
302  int j;
303 
304  Tcl_DStringInit(&dstr);
305 
306  tol_item = console_stack.Cdr();
307  while (tol_item) {
308    so = (BSyntaxObject*)Car(tol_item);
309   
310    /* GRAMMAR NAME */
311    btxt = so->Grammar()->Name();
312    Tcl_ExternalToUtfDString(NULL,btxt,-1,&dstr);
313    robjv[0] = Tcl_NewStringObj(Tcl_DStringValue(&dstr),-1);
314    Tcl_DStringFree(&dstr);
315   
316    /* OBJECT NAME */
317//  btxt = so->Identify();
318    GetName( so, btxt );
319    Tcl_ExternalToUtfDString(NULL,btxt,-1,&dstr);
320    robjv[1] = Tcl_NewStringObj(Tcl_DStringValue(&dstr),-1);
321    Tcl_DStringFree(&dstr);
322   
323    /* OBJECT CONTENT */
324    btxt = so->Info();
325    Tcl_ExternalToUtfDString(NULL,btxt,-1,&dstr);
326    robjv[2] = Tcl_NewStringObj(Tcl_DStringValue(&dstr),-1);
327    Tcl_DStringFree(&dstr);
328   
329    /* OBJECT PATH */
330    btxt = so->SourcePath();
331    Tcl_ExternalToUtfDString(NULL,btxt,-1,&dstr);
332    robjv[3] = Tcl_NewStringObj(Tcl_DStringValue(&dstr),-1);
333    Tcl_DStringFree(&dstr);
334   
335    /* OBJECT DESCRIPTION */
336    btxt = so->Description();
337    Tcl_ExternalToUtfDString(NULL,btxt,-1,&dstr);
338    robjv[4] = Tcl_NewStringObj(Tcl_DStringValue(&dstr),-1);
339    Tcl_DStringFree(&dstr);
340   
341    /* IS THE OBJECT A FILE? */
342    robjv[5] = Tcl_NewIntObj(so->IsFile());
343////    if ( so->Grammar()==GraSet() ) {
344    if ( so->Grammar()==GraSet() || so->Grammar()==GraNameBlock()) {
345      /* HAS SUBSET */
346////      ptrSet = &(((BUserSet*)so)->Contens());
347      ptrSet = ContainerGetSet(so);
348      tmpCard = ptrSet->Card();
349      for (j=1; j<=tmpCard; ++j )
350        if ( (*ptrSet)[j]->Grammar()==GraSet() )
351          break;
352      robjv[6] = Tcl_NewIntObj(j<=tmpCard);
353       
354      /* SUBTYPE INFO */
355      robjv[7] = Tcl_NewIntObj( ptrSet->SubType() );
356       
357      /* STRUCT INFO */
358      if ( ptrSet->Struct() ) {
359        btxt = ptrSet->Struct()->Name();
360        Tcl_ExternalToUtfDString(NULL,btxt,-1,&dstr);
361        robjv[8] = Tcl_NewStringObj( Tcl_DStringValue(&dstr), -1 );
362        Tcl_DStringFree( &dstr );
363      } else
364        robjv[8] = Tcl_NewStringObj( NULL, 0 );
365      robjc = 9;
366    } else
367      robjc = 6;
368   
369    /* build the tcl item as a list */
370    tcl_item = Tcl_NewListObj(robjc,robjv);
371   
372    /* append to the end of the result */
373    tcl_result = Tcl_ListObjAppendElement(interp,obj_result,tcl_item);
374    if (tcl_result != TCL_OK) {
375      Tcl_SetStringObj(obj_result,"",-1);
376      Tcl_AppendObjToObj(obj_result,Tcl_GetObjResult(interp));
377      return TCL_ERROR;
378    }
379    tol_item = Cdr(tol_item);
380  }
381  return TCL_OK;
382}
383
384struct tcl_info_t
385{
386  Tcl_Interp *interp;
387  int objc;
388  Tcl_Obj* CONST* objv;
389  Tcl_DString &dstr;
390};
391
392/*
393 * Tol_ReleaseStack --
394 *
395 * Recursive version in order to release stack in reverse order
396 *
397 * Preconditions:
398 *
399 *   P != NULL
400 */
401static
402int Tol_ReleaseStack(tcl_info_t &info, BList *P)
403{
404  int result;
405 
406  assert(P != NULL);
407
408  if (P->Cdr()) {
409    /* keep on looking for rest of items */
410    result = Tol_ReleaseStack(info, P->Cdr());
411    /* process this item */
412    BList *current = P->Cdr();
413    BSyntaxObject * so;
414    int i;
415    so = (BSyntaxObject*)(current->Car());
416    if (info.objc) {
417      const char* name = so->Name().String();
418      for (i = 0; i<info.objc; ++i) {
419        Tcl_UtfToExternalDString(NULL,Tcl_GetString(info.objv[i]),-1,
420                                 &info.dstr);
421        if (!strcmp(Tcl_DStringValue(&info.dstr), name)) {
422          Tcl_DStringFree(&info.dstr);
423          break;
424        }
425        Tcl_DStringFree(&info.dstr);
426      }
427    } else {
428      /* mark current as being found */
429      i = -1;
430    }
431    if (i<info.objc) {
432      BList *next = current->Cdr();
433      /* delete will DecNRefs to the Car */
434      delete current;
435      /* now try to release the BSyntaxObject */
436      DESTROY(so);
437      /* chain the list */
438      P->PutCdr(next);
439    }
440  } else {
441    /* EOR */
442    result = TCL_OK;
443  }
444  return result;
445}
446
447int Tol_ReleaseStack(Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[],
448                     Tcl_Obj * obj_result)
449{
450  Tcl_DString dstr;
451  tcl_info_t tcl_info = {interp, objc, objv, dstr};
452  Tcl_DStringInit(&dstr);
453
454  return Tol_ReleaseStack(tcl_info, &console_stack);
455}
456
457/*!
458 * Tol_GetConsoleObject --
459 *
460 *     Returns the object with given index in the console object list.
461 */
462BSyntaxObject * Tol_GetConsoleObject(int index )
463{
464  BList * current = console_stack.Cdr();
465  int i = 1;
466  while (current) {
467    if (i==index) break;
468    current = Cdr(current);
469    ++i;
470  }
471  return current ? (BSyntaxObject*)(current->Car()) : NULL;
472}
473
474
475/*
476 * return the container (File, Set or NameBlock) with name obj_name,
477 * in case of error return NULL and leave a description in
478 * obj_result.
479 *
480 */
481BSyntaxObject * Tol_FindGlobalContainer(const char* Type,
482                                        const char* obj_name,
483                                        Tcl_Obj*    obj_result)
484{
485  BGrammar *gra;
486  BSyntaxObject* var;
487  Tcl_DString uniBuffer;
488
489  if (!strcmp(Type, "Set"))
490    gra = GraSet();
491  else if (!strcmp(Type, "NameBlock"))
492    gra = GraNameBlock();
493  else if (!strcmp(Type, "File"))
494    gra = NULL;
495  else {
496    Tcl_AppendStringsToObj(obj_result,"type '",
497                           Type,
498                           "' is not a container grammar", NULL );
499    return NULL;
500  }
501  Tcl_DStringInit(&uniBuffer);
502  Tcl_UtfToExternalDString(NULL,obj_name,-1,&uniBuffer);
503  if (!gra) {
504    /* should look in Files */
505    BText fname(Tcl_DStringValue(&uniBuffer));
506    if (!(var=(BSyntaxObject*)BSetFromFile::FindCompiled(fname))) {
507      Tcl_AppendStringsToObj(obj_result,"file \"",
508                             obj_name,
509                             "\" is not included", NULL );
510    }
511  } else if (!(var=gra->FINDVARIABLE(Tcl_DStringValue(&uniBuffer)))) {
512      Tcl_AppendStringsToObj(obj_result,"\"",
513                             obj_name,
514                             "\" isn't a ", Type, " variable", NULL );
515  }
516  Tcl_DStringFree(&uniBuffer);
517  return var;
518}
519
520/*
521 * given a tol set, returns its child corresponding to the set of
522 * indexes indexes of size n.  In case of error return NULL and leave
523 * a description in obj_result.
524 *
525 */
526
527BSyntaxObject * Tol_FindChild(Tcl_Interp    *interp,
528                              BSyntaxObject *syn_obj,
529                              Tcl_Obj       **indexes, int n,
530                              Tcl_Obj       *obj_result)
531{
532  int tcl_code;
533  Tcl_DString dstr;
534  BSet *container;
535  int idx, card;
536  int i;
537
538  for (i=0; i<n; ++i) {
539    if (!(container = ContainerGetSet(syn_obj))) {
540      BText info(syn_obj->Info());
541      Tcl_DStringInit(&dstr);
542      Tcl_ExternalToUtfDString(NULL,info,-1,&dstr);
543      Tcl_AppendStringsToObj(obj_result,"object \"",
544                             Tcl_DStringValue(&dstr),
545                             "\" is not a container",
546                             NULL);
547      Tcl_DStringFree(&dstr);
548      break;
549    }
550    /* get the current object index */
551    tcl_code = Tcl_GetIntFromObj(interp,indexes[i],&idx);
552    if (tcl_code != TCL_OK) {
553      Tcl_AppendObjToObj( obj_result, Tcl_GetObjResult(interp));
554      break;
555    }
556    card = container->Card();
557    if (idx<1 || idx>card) {
558      Tcl_AppendStringsToObj(obj_result,
559                             "index '",
560                             Tcl_GetString(indexes[i]),
561                             "' out of range",
562                             NULL);
563      break;
564    }
565    /* take the next object in the list */
566    syn_obj = (*container)[idx];
567  }
568  return i == n ? syn_obj : NULL;
569}
570
571/*!
572 *  Tol_ResolveObject --
573 *
574 *     Resolve a SyntaxObject given a toltcl object reference. A
575 *     reference is {TYPE ?container? i1 i2 ... in} or a global
576 *     container's name of type File|Set|NameBlock|Console. When TYPE
577 *     is Console then container is not given. The grammar of the
578 *     object found is matched to the given argument grammar. If the
579 *     return value is NULL an error message is left in interp.
580 */
581
582BSyntaxObject * Tol_ResolveObject(Tcl_Interp *interp,
583                                  Tcl_Obj    *obj_ref,
584                                  Tcl_Obj    *obj_result)
585{
586  Tcl_Obj ** items;
587  int n;
588  int tcl_code;
589  char * type;
590
591  /* look for subitem given in obj_ref */
592  tcl_code = Tcl_ListObjGetElements(interp, obj_ref, &n, &items);
593  if (tcl_code != TCL_OK) {
594    Tcl_AppendObjToObj(obj_result,Tcl_GetObjResult(interp));
595    return NULL;
596  }
597
598  // this Tcl_Obj is to leave error messages
599  BSyntaxObject * syn = NULL;
600
601  if (n >= 2) {
602    type = Tcl_GetString(items[0]);
603    if (!strcmp(type,"Console") || !strcmp(type,"File") ||
604        !strcmp(type,"Set") || !strcmp(type,"NameBlock") ) {
605      if (!strcmp(type,"Console")) {
606        // is a reference in the console, items[1] is the first index in
607        // the path, following indexes are indexes withing containers.
608        int i1;
609        if ((tcl_code = Tcl_GetIntFromObj(interp,items[1],&i1)!=TCL_OK)) {
610          Tcl_AppendObjToObj(obj_result,Tcl_GetObjResult(interp));
611          return NULL;
612        }
613        if (!(syn=Tol_GetConsoleObject(i1))) {
614          Tcl_AppendStringsToObj(obj_result, "index ",
615                                 Tcl_GetString(items[1]),
616                                 " not found in console", NULL);
617          return NULL;
618        }
619      } else {
620      /* should be File, Set or NameBlock, it is a hierarchical container */
621        if (!(syn=Tol_FindGlobalContainer(Tcl_GetString(items[0]),
622                                          Tcl_GetString(items[1]),
623                                          obj_result))) {
624          return NULL;
625        }
626      }
627      assert(syn);
628      if (n>2) {
629        // there are more indexes & syn should be a Container
630        if (!(syn=Tol_FindChild(interp,
631                                syn, items+2, n-2, obj_result))) {
632          return NULL;
633        }
634      }
635    } else {
636      if ( n==2 ) {
637        if ( !strcasecmp( type, "ADDRESS" ) ) {
638          return
639            BSyntaxObject::GetObjectFromAddress( Tcl_GetString( items[1] ) );
640        } else {
641          // look global var in grammar
642          BGrammar * gra;
643          gra = BGrammar::FindByName(type);
644          if (!gra) {
645            Tcl_AppendStringsToObj(obj_result, "\"",
646                                   type,
647                                   "\" isn't a grammar", NULL);
648            return NULL;
649          }
650          Tcl_DString dstr;
651          Tcl_DStringInit(&dstr);
652          Tcl_UtfToExternalDString(NULL,Tcl_GetString(items[1]),-1,&dstr);
653          if (!(syn = gra->FINDVARIABLE(Tcl_DStringValue(&dstr))))
654            Tcl_AppendStringsToObj(obj_result, "variable '",
655                                   obj_ref, "' not found in grammar '",
656                                   gra->Name().String(), "'", NULL);
657          Tcl_DStringFree(&dstr);
658          /* found and matched */
659          return syn;
660        }
661      } else {
662        Tcl_AppendStringsToObj(obj_result,
663                               "invalid object reference in ResolveObject",
664                               NULL);
665      }
666    }
667  } else {
668      Tcl_AppendStringsToObj(obj_result,
669                             "invalid object reference in ResolveObject",
670                             NULL);
671  }
672/*  if (grammar && syn && syn->Grammar()!=grammar) {
673    Tcl_AppendStringsToObj(obj_result, "grammar for object '",
674                           Tcl_GetString(obj_ref),
675                           "' does not match grammar '",
676                           grammar->Name().String(), "'", NULL);
677    syn = NULL;
678  }
679*/
680  return syn;
681}
682
683int Tol_FindSOInSet(BSet * ptrSet, const BSyntaxObject * syn,
684                    ToltclPool & indexes)
685{
686  int j;
687  BSyntaxObject * so;
688 
689  for (j = 1; j <= ptrSet->Card(); j++) {
690    so = (*ptrSet)[j];
691    BSet *ptrSet;
692    if (so == syn || ((ptrSet=ContainerGetSet(so)) &&
693                      Tol_FindSOInSet(ptrSet,
694                                      syn, indexes))) {
695      /* found!!! */
696      indexes.AppendObject((void*)j);     
697      return 1;
698    }
699  }
700
701  return 0;
702}
703 
704/*
705 *  Puts in obj_result the global reference of the given
706 *  syntaxobject. The syntaxobject could be given as set member or as
707 *  global variable. In case of error leave in obj_result the message.
708 *  Returns TCL_OK if succesfull or TCL_ERROR in case of error.
709 */
710
711int Tol_GetReference(Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[],
712                     Tcl_Obj * obj_result)
713{
714  Tcl_Obj ** items;
715  int n;
716  int tcl_code;
717  const BSyntaxObject * source, * syn;
718  BSet * ptrSet;
719  ToltclPool indexes;
720  Tcl_DString dstr;
721  int j;
722  char * graname, * objname;
723
724  assert(!Tcl_IsShared(obj_result));
725  tcl_code = Tcl_ListObjGetElements(interp,objv[0],&n,&items);
726  assert(tcl_code == TCL_OK);
727  if (n<2) {
728    Tcl_AppendStringsToObj(obj_result,
729                           "wrong # args: should be 'tol::info",
730                           " reference {grammar|container objname ?indexes?}'",
731                           NULL);
732    return TCL_ERROR;   
733  }
734  if (n==2 && strcmp(Tcl_GetString(items[0]),"Console")) {
735  // global access
736    BGrammar * gra;
737    graname = Tcl_GetString(items[0]);
738    gra = BGrammar::FindByName(graname);
739    if (!gra) {
740      Tcl_AppendStringsToObj( obj_result, "\"",
741                              graname,
742                              "\" isn't a grammar", NULL);
743      return TCL_ERROR;
744    }
745    objname = Tcl_GetString(items[1]);
746    Tcl_UtfToExternalDString(NULL,objname,-1,&dstr);
747    syn = gra->FINDVARIABLE(Tcl_DStringValue(&dstr));
748    Tcl_DStringFree(&dstr);
749    if (!syn) {
750      Tcl_AppendStringsToObj(obj_result, "\"",
751                             Tcl_GetString(items[1]),
752                             "\" isn't a variable in grammar ",
753                             graname, NULL);
754      return TCL_ERROR;
755    }
756    source = syn->Source();
757    if (!source) {
758      /* is a global variable not defined inside a file */
759      items = (Tcl_Obj**)Tcl_Alloc(sizeof(Tcl_Obj*) * 2);
760      Tcl_ExternalToUtfDString(NULL, graname, -1, &dstr);
761      items[0] = Tcl_NewStringObj(Tcl_DStringValue(&dstr), -1);
762      Tcl_DStringFree(&dstr);
763      Tcl_ExternalToUtfDString(NULL, objname, -1, &dstr);
764      items[1] = Tcl_NewStringObj(Tcl_DStringValue(&dstr), -1);
765      Tcl_DStringFree(&dstr);
766      Tcl_SetListObj(obj_result, 2, items);
767      Tcl_Free((char*)items);
768      return TCL_OK;
769    }
770  } else {
771    // member access
772    if (!(syn=Tol_ResolveObject(interp,objv[0],obj_result))) {
773      return TCL_ERROR;
774    }
775    /* here we have a valid reference */
776    tcl_code = Tcl_ListObjGetElements(interp,objv[0],&n,&items);
777    assert(tcl_code == TCL_OK);
778    if (!strcmp(Tcl_GetString(items[0]),"File") ||
779        !strcmp(Tcl_GetString(items[0]),"Console")) {
780      /* here we have in objv[0] the answer */
781      Tcl_SetListObj(obj_result, n, items);
782      return TCL_OK;     
783    }
784    source = syn->Source();
785    if (!source) {
786      /* here we have in objv[0] the answer too */
787      Tcl_SetListObj(obj_result, n, items);
788      return TCL_OK;
789    }
790  }
791  /* at this point variable has to be defined inside a file */
792  assert(source);
793  ptrSet = &(((BUserSet*)source)->Contens());
794  if (Tol_FindSOInSet(ptrSet, syn, indexes)) {
795    items = (Tcl_Obj**)Tcl_Alloc(sizeof(Tcl_Obj*) * (indexes.GetSize()+2));
796    Tcl_ExternalToUtfDString(NULL, "File", -1, &dstr);
797    items[0] = Tcl_NewStringObj(Tcl_DStringValue(&dstr), -1);
798    Tcl_DStringFree(&dstr);
799    Tcl_ExternalToUtfDString(NULL, source->Name(), -1, &dstr);
800    items[1] = Tcl_NewStringObj(Tcl_DStringValue(&dstr), -1);
801    Tcl_DStringFree(&dstr);
802    int last = indexes.GetLast();
803    for(j = last; j >= 0; j--)
804      items[last+2-j] = Tcl_NewIntObj(long(*indexes._GetObject(j)));
805    Tcl_SetListObj(obj_result, indexes.GetSize()+2, items);
806    Tcl_Free((char*)items);
807    return TCL_OK;
808  } else {
809    /* this should not happend because syn should be inside syn->source */
810    Tcl_AppendStringsToObj(obj_result,
811                             "internal error: syn not found in syn->Source()",
812                             NULL);
813    return TCL_ERROR;
814  }
815}
816
817inline void SAVE_SET_STRING( Tcl_Obj **obj, Tcl_DString* dstr )
818{
819  if (Tcl_IsShared( *obj ) ) {
820    Tcl_DecrRefCount( *obj );
821    *obj = Tcl_NewStringObj( Tcl_DStringValue( dstr ), -1 );
822    Tcl_IncrRefCount( *obj );
823  } else
824    Tcl_SetStringObj( *obj, Tcl_DStringValue( dstr ),-1 );
825}
826
827inline void SAVE_SET_STRING( Tcl_Obj **obj, const char* str )
828{
829  if (Tcl_IsShared( *obj ) ) {
830    Tcl_DecrRefCount( *obj );
831    *obj = Tcl_NewStringObj( str, -1 );
832    Tcl_IncrRefCount( *obj );
833  } else
834    Tcl_SetStringObj( *obj, str,-1 );
835}
836
837class ContainerIterator
838{
839public:
840
841  static ContainerIterator *New( BSyntaxObject *obj );
842 
843  enum status_t { VALID, INVALID };
844
845  virtual ~ContainerIterator( ) { }
846 
847  status_t GetStatus() const {
848    return m_status;
849  }
850 
851  virtual status_t Begin( ) = 0;
852  virtual BSyntaxObject *Next( ) = 0;
853
854protected:
855
856  ContainerIterator() : m_status( INVALID ) { }
857 
858  status_t m_status;
859};
860
861class SetIterator : public ContainerIterator
862{
863public:
864  SetIterator( BSet *set )
865  {
866    m_set = set;
867    Begin();
868  }
869
870  virtual ~SetIterator( )
871  {
872  }
873 
874  virtual ContainerIterator::status_t Begin()
875  {
876    m_idx = 0;
877    m_status = m_set ? VALID : INVALID;
878    return m_status;
879  }
880 
881  virtual BSyntaxObject *Next()
882  {
883    BSyntaxObject *so = _next();
884    if ( !so ) {
885      /* start over */
886      Begin();
887    }
888    return so;
889  }
890
891protected:
892
893  BSyntaxObject *_next()
894  {
895    if ( m_set ) {
896      ++m_idx;
897      return ( m_idx > m_set->Card( ) ) ? NULL : ( *m_set )[ m_idx ];
898    }
899    return NULL;
900  }
901
902  size_t m_idx;
903  BSet *m_set;
904};
905
906class USetIterator : public SetIterator
907{
908public:
909  USetIterator( BUserSet *uset )
910    : SetIterator( &( uset->Contens( ) ) )
911  {
912  }
913  virtual ~USetIterator() { }
914};
915
916class UNameBlockIterator : public SetIterator
917{
918public:
919  UNameBlockIterator( BUserNameBlock *unb )
920    : SetIterator( &( unb->Contens( ).Set( ) ) ),
921      m_data_static( NULL ),
922      m_methods_static( NULL ),
923      m_methods_instance( NULL ),
924      m_ptr_item( NULL )
925  {
926    const BClass *cls = unb->Contens( ).Class( );
927    if ( cls ) {
928      m_data_static = cls->SelectStaticMembers( NULL );
929      m_methods_static = cls->SelectStaticMethods( NULL );
930      m_methods_instance = cls->SelectNonStaticMethods( NULL );
931    }
932  }
933
934  virtual ~UNameBlockIterator( )
935  {
936    DESTROY( m_data_static );
937    DESTROY( m_methods_static );
938    DESTROY( m_methods_instance );
939  }
940 
941  virtual status_t Begin( )
942  {
943    SetIterator::Begin( );
944    m_ptr_item = NULL;
945    return GetStatus( );
946  }
947 
948  virtual BSyntaxObject *Next()
949  {
950    BSyntaxObject *so;
951   
952    so = _next();
953   
954    if ( so ) {
955      return so;
956    }
957   
958    if ( m_ptr_item ) {
959      m_ptr_item = Cdr( m_ptr_item );
960    } else {
961      m_ptr_item = m_methods_instance;
962    }
963
964    if ( m_ptr_item ) {
965      return (BSyntaxObject*)Car( m_ptr_item );
966    } else {
967      // si despues de avanzar no encuentro 'obj', lo dejo listo para
968      // que de la vuelta
969      Begin( );
970      return NULL;
971    }
972  }
973
974private:
975  BList *m_data_static;
976  BList *m_methods_static;
977  BList *m_methods_instance;
978  BList *m_ptr_item;
979};
980
981ContainerIterator *ContainerIterator::New( BSyntaxObject *obj )
982{
983  if ( obj->Grammar( ) == GraSet( ) ) {
984    return new USetIterator( (BUserSet*)obj );
985  }
986  if ( obj->Grammar( ) == GraNameBlock( ) ) {
987    return new UNameBlockIterator( (BUserNameBlock*)obj );
988  }
989  return NULL;
990}
991
992/*! Implement a foreach proc similar to the one provided in Tcl except
993 *  that instead of iterating over the list's items it iterates over
994 *  the Set's items. The set could be tolset if the indexes is empty
995 *  or tolset[i1][i2]...[ik] for the given indexes {i1,i2,...,ik}
996 */
997int Tol_ForEach (Tcl_Interp * interp,
998                 int objc,
999                 Tcl_Obj *CONST objv[],
1000                 Tcl_Obj * obj_result)
1001{
1002  BSyntaxObject* container;
1003  Tcl_DString dstr;
1004  Tcl_Obj * ArgIndexes;
1005  int tcl_code = TCL_OK;
1006  int i;
1007  int n, index_length;
1008  Tcl_Obj ** items;
1009
1010  int length = 0;
1011
1012  if ( Tcl_GetCharLength( objv[ 0 ] ) == 0 ) {
1013    Tcl_AppendStringsToObj( obj_result, "empty loop variable name", NULL );
1014    return TCL_ERROR;
1015  }
1016 
1017  if ( Tcl_ListObjLength( interp, objv[ 1 ], &length) != TCL_OK ) {
1018    Tcl_AppendObjToObj( obj_result, Tcl_GetObjResult( interp ) );
1019    return TCL_ERROR;
1020  }
1021  if ( length < 2 ) {
1022    Tcl_AppendStringsToObj( obj_result,
1023                            "invalid object reference '",
1024                            Tcl_GetString(objv[0]),
1025                            "must be {TYPE ?name? i1 i2 ... ik}",
1026                            NULL );
1027    return TCL_ERROR;
1028  }
1029
1030  const int OBJ_GRAMMAR    = 0;
1031  const int OBJ_GRAMMARV   = OBJ_GRAMMAR + 1;
1032  const int OBJ_NAME       = OBJ_GRAMMARV + 1;
1033  const int OBJ_NAMEV      = OBJ_NAME + 1;
1034  const int OBJ_CONTENT    = OBJ_NAMEV + 1;
1035  const int OBJ_CONTENTV   = OBJ_CONTENT + 1;
1036  const int OBJ_PATH       = OBJ_CONTENTV + 1;
1037  const int OBJ_PATHV      = OBJ_PATH + 1;
1038  const int OBJ_DESC       = OBJ_PATHV + 1;
1039  const int OBJ_DESCV      = OBJ_DESC + 1;
1040  const int OBJ_INDEXES    =  OBJ_DESCV + 1;
1041  const int OBJ_INDEXESV   =  OBJ_INDEXES + 1;
1042  const int OBJ_ISFILE     = OBJ_INDEXESV + 1;
1043  const int OBJ_ISFILEV    = OBJ_ISFILE + 1;
1044  const int OBJ_HASSUBSET  = OBJ_ISFILEV + 1;
1045  const int OBJ_HASSUBSETV = OBJ_HASSUBSET + 1;
1046  const int OBJ_SUBTYPE    = OBJ_HASSUBSETV + 1;
1047  const int OBJ_SUBTYPEV   = OBJ_SUBTYPE + 1;
1048  const int OBJ_STRUCT     = OBJ_SUBTYPEV + 1;
1049  const int OBJ_STRUCTV    = OBJ_STRUCT + 1;
1050  const int NUM_OBJS      = OBJ_STRUCTV + 1;
1051
1052  int datac;
1053  Tcl_Obj *datav[ NUM_OBJS ];
1054
1055 
1056  if ( !( container = Tol_ResolveObject( interp, objv[ 1 ], obj_result ) ) ) {
1057    return TCL_ERROR;
1058  }
1059  ContainerIterator *citer = ContainerIterator::New( container );
1060 
1061  if ( !citer ) {
1062    Tcl_AppendStringsToObj(obj_result,
1063                           "object '",
1064                           Tcl_GetString( objv[ 1 ] ),
1065                           "' is not a valid container ",
1066                           NULL);
1067    return TCL_ERROR;
1068  }
1069 
1070  // is ok to ask for a list
1071  Tcl_ListObjGetElements( interp, objv[ 1 ], &n, &items );
1072
1073  // initialize the list of indexes (the common part) for every item
1074  // in the Set
1075  if (strcmp(Tcl_GetString( items[ 0 ] ),"Console")) {
1076    if (n>2)
1077      ArgIndexes = Tcl_NewListObj( n - 2, items + 2 );
1078    else
1079      ArgIndexes = Tcl_NewListObj( 0, NULL );
1080  } else {
1081    if ( n > 1 )
1082      ArgIndexes = Tcl_NewListObj( n - 1, items + 1 );
1083    else
1084      ArgIndexes = Tcl_NewListObj( 0, NULL );
1085  }
1086
1087  datav[ OBJ_GRAMMAR ]  = Tcl_NewStringObj( "grammar", -1 );
1088  datav[ OBJ_GRAMMARV ] = Tcl_NewObj( );
1089  datav[ OBJ_NAME ]     = Tcl_NewStringObj( "name", -1 );
1090  datav[ OBJ_NAMEV ]    = Tcl_NewObj( );
1091  datav[ OBJ_CONTENT ]  = Tcl_NewStringObj( "content", -1 );
1092  datav[ OBJ_CONTENTV ] = Tcl_NewObj( );
1093  datav[ OBJ_PATH ]     = Tcl_NewStringObj( "path", -1 );
1094  datav[ OBJ_PATHV ]    = Tcl_NewObj( );
1095  datav[ OBJ_DESC ]     = Tcl_NewStringObj( "description", -1 );
1096  datav[ OBJ_DESCV ]    = Tcl_NewObj( );
1097  Tcl_Obj * last_index  = Tcl_NewIntObj( 1 );
1098  Tcl_ListObjAppendElement( NULL, ArgIndexes, last_index );
1099  datav[ OBJ_INDEXES ]  = Tcl_NewStringObj( "indexes", -1 );
1100  datav[ OBJ_INDEXESV ] = ArgIndexes;
1101  Tcl_ListObjLength( NULL, datav[ OBJ_INDEXES ], &index_length );
1102  datav[ OBJ_ISFILE ]     = Tcl_NewStringObj( "isfile", -1 );
1103  datav[ OBJ_ISFILEV ]    = Tcl_NewObj( );
1104  datav[ OBJ_HASSUBSET ]  = Tcl_NewStringObj( "hassubset", -1 );
1105  datav[ OBJ_HASSUBSETV ] = Tcl_NewObj( );
1106  datav[ OBJ_SUBTYPE ]    = Tcl_NewStringObj( "subtype", -1 );
1107  datav[ OBJ_SUBTYPEV ]   = Tcl_NewObj( );
1108  datav[ OBJ_STRUCT ]     = Tcl_NewObj( );
1109  datav[ OBJ_STRUCTV ]    = Tcl_NewObj( );
1110
1111  // the just created objects have refcount = 0
1112  for ( i = 0; i < NUM_OBJS; ++i ) {
1113    Tcl_IncrRefCount( datav[ i ] );
1114  }
1115 
1116  BSyntaxObject *syn_i;
1117  BSet          *set_i; /* just in case syn_i be a container */
1118
1119  /* now iter over its children */
1120 
1121  Tcl_DStringInit( &dstr );
1122  BText btxt;
1123 
1124  for ( i = 1; ( syn_i = citer->Next( ) ); ++i ) {
1125    /* read the grammar */
1126   
1127    btxt = syn_i->Grammar( )->Name( );
1128    Tcl_ExternalToUtfDString( NULL, btxt, -1, &dstr );
1129    SAVE_SET_STRING( datav + OBJ_GRAMMARV, &dstr );
1130    Tcl_DStringFree(&dstr);
1131   
1132    /* read the name */
1133    //btxt = syn_i->Identify();
1134    GetName( syn_i, btxt );
1135    Tcl_ExternalToUtfDString(NULL,btxt,-1,&dstr);
1136    SAVE_SET_STRING( datav + OBJ_NAMEV, &dstr );
1137    Tcl_DStringFree(&dstr);
1138   
1139    /* read the content */
1140    btxt = syn_i->Info();
1141    Tcl_ExternalToUtfDString(NULL,btxt,-1,&dstr);
1142    SAVE_SET_STRING( datav + OBJ_CONTENTV, &dstr );
1143    Tcl_DStringFree(&dstr);
1144   
1145    /* read the path */
1146    btxt = syn_i->SourcePath();
1147    Tcl_ExternalToUtfDString(NULL,btxt,-1,&dstr);
1148    SAVE_SET_STRING( datav + OBJ_PATHV, &dstr );
1149    Tcl_DStringFree(&dstr);
1150   
1151    /* read the description */   
1152    btxt = syn_i->Description();
1153    Tcl_ExternalToUtfDString(NULL,btxt,-1,&dstr);
1154    SAVE_SET_STRING( datav + OBJ_PATHV, &dstr );
1155    Tcl_DStringFree(&dstr);
1156
1157    /* update last index */
1158    if ( Tcl_IsShared( last_index ) ) {
1159      last_index = Tcl_NewIntObj( i );
1160      Tcl_ListObjReplace( NULL, datav[ OBJ_INDEXESV ], index_length-1,
1161                          1, 1, &last_index );
1162    } else {
1163      Tcl_SetIntObj( last_index, i );
1164    }
1165    /* to refresh the string */
1166    Tcl_InvalidateStringRep( datav[ OBJ_INDEXESV ] );
1167    // Este if es para incluir en los items que son Set informacion
1168    // que solo ellos llevan como: Subtype, IsFile, etc ...
1169
1170    if ( ( set_i = ContainerGetSet( syn_i ) ) ) {
1171      if ( Tcl_IsShared( datav[ OBJ_ISFILEV ] ) ) {
1172        Tcl_DecrRefCount( datav[ OBJ_ISFILEV ] );
1173#ifdef ISFILE_IMPLEMENTED
1174        datav[ OBJ_ISFILEV ] = Tcl_NewIntObj( syn_i->IsFile( ) );
1175#else
1176        datav[OBJ_ISFILEV] = Tcl_NewIntObj( 0 );
1177#endif
1178        Tcl_IncrRefCount( datav[ OBJ_ISFILEV ] );
1179      } else
1180#ifdef ISFILE_IMPLEMENTED
1181        Tcl_SetIntObj( datav[ OBJ_ISFILEV ], syn_i->IsFile( ) );
1182#else
1183      Tcl_SetIntObj( datav[ OBJ_ISFILEV ], 0 );
1184#endif
1185      /* verify if has subset */
1186      int tmpCard = set_i->Card( );
1187      int j;
1188      for ( j = 1; j <= tmpCard; ++j )
1189        if ( ContainerGetSet( ( *set_i )[ j ] ) )
1190          break;
1191      if ( Tcl_IsShared( datav[ OBJ_HASSUBSETV ] ) ) {
1192        Tcl_DecrRefCount( datav[ OBJ_HASSUBSETV ] );
1193        datav[ OBJ_HASSUBSETV ] = Tcl_NewIntObj( j <= tmpCard );
1194        Tcl_IncrRefCount( datav[ OBJ_HASSUBSETV ] );
1195      } else
1196        Tcl_SetIntObj( datav[ OBJ_HASSUBSETV ], j <= tmpCard );
1197       
1198      /* subtype info */
1199      if ( Tcl_IsShared( datav[ OBJ_SUBTYPEV ] ) ) {
1200        Tcl_DecrRefCount( datav[ OBJ_SUBTYPEV ] );
1201        datav[ OBJ_SUBTYPEV ] = Tcl_NewIntObj( set_i->SubType( ) );
1202        Tcl_IncrRefCount( datav[ OBJ_SUBTYPEV ] );
1203      } else
1204        Tcl_SetIntObj( datav[ OBJ_SUBTYPEV ], set_i->SubType( ) );
1205       
1206      /* STRUCT OR CLASS INFO */
1207      // asume que dstr esta a longitud 0
1208      if ( syn_i->Grammar() == GraNameBlock() ) {
1209        SAVE_SET_STRING( datav + OBJ_STRUCT, "class" );
1210        const BNameBlock& nb = ((BUserNameBlock*)(syn_i))->Contens();
1211        const BClass* cls = nb.Class( );
1212        if ( cls ) {
1213          btxt = cls->FullName();
1214          Tcl_ExternalToUtfDString( NULL, btxt, -1, &dstr );
1215        }
1216      } else {
1217        SAVE_SET_STRING( datav + OBJ_STRUCT, "struct" );
1218        if ( set_i->Struct( ) ) {
1219          btxt = set_i->Struct( )->Name( );
1220          Tcl_ExternalToUtfDString( NULL, btxt, -1, &dstr );
1221        }
1222      }
1223      SAVE_SET_STRING( datav + OBJ_STRUCTV, &dstr );
1224      Tcl_DStringFree( &dstr );
1225      datac = NUM_OBJS;
1226    } else
1227      datac = OBJ_INDEXESV + 1;
1228    // set the loop variable
1229    Tcl_Obj *varValuePtr = Tcl_ObjSetVar2( interp, objv[ 0 ], NULL,
1230                                           Tcl_NewListObj( datac, datav ),
1231                                           TCL_LEAVE_ERR_MSG );
1232    if (varValuePtr == NULL) {
1233      Tcl_AppendObjToObj( obj_result, Tcl_GetObjResult( interp ) );
1234      Tcl_AppendStringsToObj( obj_result,
1235                              "\n    (setting foreach loop variable \"",
1236                              Tcl_GetString( objv[ 0 ] ), "\")",
1237                              NULL );
1238      tcl_code = TCL_ERROR;
1239      break;
1240    }
1241    tcl_code = Tcl_EvalObjEx( interp, objv[ 2 ], 0 );
1242    if ( tcl_code != TCL_OK) {
1243      if ( tcl_code == TCL_CONTINUE) {
1244        tcl_code = TCL_OK;
1245      } else if ( tcl_code == TCL_BREAK) {
1246        tcl_code = TCL_OK;
1247        break;
1248      } else if ( tcl_code == TCL_ERROR) {
1249        Tcl_AppendObjToObj( obj_result, Tcl_GetObjResult( interp ) );
1250        break;
1251      } else {
1252        break;
1253      }
1254    }
1255  }
1256
1257  delete citer;
1258 
1259  /* liberar los objetos tcl */
1260  for ( i = 0; i < NUM_OBJS; ++i ) {
1261    Tcl_DecrRefCount( datav[ i ] );
1262  }
1263  return tcl_code;
1264}
1265
1266
1267/*
1268 * Iterate over a first level's children of a given set.  The set
1269 * could be a container Set, File or NameBlock if the index list is
1270 * empty or container[i1][i2]...[ik] for the given indexes
1271 * {i1,i2,...,ik}
1272 *
1273 * Used by tol::forallchil
1274 *
1275 */
1276
1277int Tol_IterChildren(Tcl_Interp * interp,
1278                     int objc,
1279                     Tcl_Obj *CONST objv[],
1280                     Tcl_Obj * obj_result)
1281{
1282  BSyntaxObject* container;
1283  Tcl_DString dstr;
1284  Tcl_Obj * ArgIndexes;
1285  int tcl_code;
1286  int i;
1287  int n, index_length;
1288  Tcl_Obj ** items;
1289  Tcl_Obj ** script_header;
1290
1291  int length = 0;
1292 
1293  if (Tcl_ListObjLength(interp,objv[0],&length)!=TCL_OK) {
1294    Tcl_AppendObjToObj(obj_result,Tcl_GetObjResult(interp));
1295    return TCL_ERROR;
1296  }
1297  if ( length < 2 ) {
1298    Tcl_AppendStringsToObj( obj_result,
1299                            "invalid object reference '",
1300                            Tcl_GetString(objv[0]),
1301                            "must be {TYPE ?name? i1 i2 ... ik}",
1302                            NULL );
1303    return TCL_ERROR;
1304  }
1305
1306  /* expand header of script */
1307  tcl_code = Tcl_ListObjGetElements( interp, objv[ 1 ],
1308                                     &length, &script_header );
1309  if ( tcl_code != TCL_OK ) {
1310    Tcl_AppendObjToObj( obj_result, Tcl_GetObjResult( interp ) );
1311    return TCL_ERROR;
1312  }
1313
1314  if ( !length ) {
1315    Tcl_AppendStringsToObj( obj_result,
1316                            "invalid script argument of length 0",
1317                            NULL );
1318    return TCL_ERROR;
1319  }
1320  int ARG_SCRIPT    = length - 1;
1321  int ARG_GRAMMAR   = ARG_SCRIPT + 1;
1322  int ARG_NAME      = ARG_GRAMMAR + 1;
1323  int ARG_CONTENT   = ARG_NAME + 1;
1324  int ARG_PATH      = ARG_CONTENT + 1;
1325  int ARG_DESC      = ARG_PATH + 1;
1326  int ARG_INDEXES   =  ARG_DESC + 1;
1327  int ARG_ISFILE    = ARG_INDEXES + 1;
1328  int ARG_HASSUBSET = ARG_ISFILE + 1;
1329  int ARG_SUBTYPE   = ARG_HASSUBSET + 1;
1330  int ARG_STRUCT    = ARG_SUBTYPE + 1;
1331  int NUM_ARGS      = ARG_STRUCT + 1;
1332 
1333  if ( !( container=Tol_ResolveObject( interp, objv[0], obj_result ) ) ) {
1334    return TCL_ERROR;
1335  }
1336  ContainerIterator *citer = ContainerIterator::New( container );
1337 
1338  if ( !citer ) {
1339    Tcl_AppendStringsToObj(obj_result,
1340                           "object '",
1341                           Tcl_GetString(objv[0]),
1342                           "' is not a valid container ",
1343                           NULL);
1344      return TCL_ERROR;
1345  }
1346 
1347  int datac;
1348  Tcl_Obj ** datav = new ( Tcl_Obj* [ NUM_ARGS ] );
1349
1350  // is ok to ask for a list
1351  Tcl_ListObjGetElements( interp, objv[ 0 ], &n, &items );
1352 
1353  if (strcmp(Tcl_GetString(items[0]),"Console")) {
1354    if (n>2)
1355      ArgIndexes = Tcl_NewListObj(n-2,items+2);
1356    else
1357      ArgIndexes = Tcl_NewListObj(0,NULL);
1358  } else {
1359    if (n>1)
1360      ArgIndexes = Tcl_NewListObj(n-1,items+1);
1361    else
1362      ArgIndexes = Tcl_NewListObj(0,NULL);
1363  }
1364
1365  for( i = 0; i < ARG_GRAMMAR; ++i ) {
1366    datav[ i ] = script_header[ i ];
1367  }
1368 
1369  datav[ARG_GRAMMAR] = Tcl_NewObj();
1370  datav[ARG_NAME]    = Tcl_NewObj();
1371  datav[ARG_CONTENT] = Tcl_NewObj();
1372  datav[ARG_PATH]    = Tcl_NewObj();
1373  datav[ARG_DESC]    = Tcl_NewObj();
1374  Tcl_Obj * last_index = Tcl_NewIntObj(1);
1375  Tcl_ListObjAppendElement(NULL,ArgIndexes,last_index);
1376  datav[ARG_INDEXES] = ArgIndexes;
1377  Tcl_ListObjLength(NULL,datav[ARG_INDEXES],&index_length);
1378  datav[ARG_ISFILE] = Tcl_NewObj();
1379  datav[ARG_HASSUBSET] = Tcl_NewObj();
1380  datav[ARG_SUBTYPE] = Tcl_NewObj();
1381  datav[ARG_STRUCT] = Tcl_NewObj();
1382  for ( i = 0; i < NUM_ARGS; ++i ) {
1383    Tcl_IncrRefCount( datav[i] );
1384  }
1385 
1386  BSyntaxObject *syn_i;
1387  BSet          *set_i; /* just in case syn_i be a container */
1388  /* now iter over its children */
1389 
1390  Tcl_DStringInit(&dstr);
1391  BText btxt;
1392 
1393  for ( i = 1; ( syn_i = citer->Next( ) ); ++i ) {
1394   
1395    /* read the grammar */
1396    btxt = syn_i->Grammar()->Name();
1397    Tcl_ExternalToUtfDString(NULL,btxt,-1,&dstr);
1398    if (Tcl_IsShared(datav[ARG_GRAMMAR])) {
1399      Tcl_DecrRefCount(datav[ARG_GRAMMAR]);
1400      datav[ARG_GRAMMAR] = Tcl_NewStringObj(Tcl_DStringValue(&dstr),-1);
1401      Tcl_IncrRefCount(datav[ARG_GRAMMAR]);
1402    } else
1403      Tcl_SetStringObj(datav[ARG_GRAMMAR], Tcl_DStringValue(&dstr),-1);
1404    Tcl_DStringFree(&dstr);
1405   
1406    /* read the name */
1407    //btxt = syn_i->Identify();
1408    GetName( syn_i, btxt );
1409    Tcl_ExternalToUtfDString(NULL,btxt,-1,&dstr);
1410    if (Tcl_IsShared(datav[ARG_NAME])) {
1411      Tcl_DecrRefCount(datav[ARG_NAME]);
1412      datav[ARG_NAME] = Tcl_NewStringObj(Tcl_DStringValue(&dstr),-1);
1413      Tcl_IncrRefCount(datav[ARG_NAME]);
1414    } else
1415      Tcl_SetStringObj(datav[ARG_NAME], Tcl_DStringValue(&dstr),-1);
1416    Tcl_DStringFree(&dstr);
1417   
1418    /* read the content */
1419    btxt = syn_i->Info();
1420    Tcl_ExternalToUtfDString(NULL,btxt,-1,&dstr);
1421    if (Tcl_IsShared(datav[ARG_CONTENT])) {
1422      Tcl_DecrRefCount(datav[ARG_CONTENT]);
1423      datav[ARG_CONTENT] = Tcl_NewStringObj(Tcl_DStringValue(&dstr),-1);
1424      Tcl_IncrRefCount(datav[ARG_CONTENT]);
1425    } else
1426      Tcl_SetStringObj(datav[ARG_CONTENT],Tcl_DStringValue(&dstr),-1);
1427    Tcl_DStringFree(&dstr);
1428   
1429    /* read the path */
1430    btxt = syn_i->SourcePath();
1431    Tcl_ExternalToUtfDString(NULL,btxt,-1,&dstr);
1432    if (Tcl_IsShared(datav[ARG_PATH])) {
1433      Tcl_DecrRefCount(datav[ARG_PATH]);
1434      datav[ARG_PATH] = Tcl_NewStringObj(Tcl_DStringValue(&dstr),-1);
1435      Tcl_IncrRefCount(datav[ARG_PATH]);
1436    } else
1437      Tcl_SetStringObj(datav[ARG_PATH],Tcl_DStringValue(&dstr),-1);
1438    Tcl_DStringFree(&dstr);
1439   
1440    /* read the description */   
1441    btxt = syn_i->Description();
1442    Tcl_ExternalToUtfDString(NULL,btxt,-1,&dstr);
1443    if (Tcl_IsShared(datav[ARG_DESC])) {
1444      Tcl_DecrRefCount(datav[ARG_DESC]);
1445      datav[ARG_DESC] = Tcl_NewStringObj(Tcl_DStringValue(&dstr),-1);
1446      Tcl_IncrRefCount(datav[ARG_DESC]);
1447    } else
1448      Tcl_SetStringObj(datav[ARG_DESC],Tcl_DStringValue(&dstr),-1);
1449    Tcl_DStringFree(&dstr);
1450   
1451    if ((set_i=ContainerGetSet(syn_i))) {
1452      /* update last index */
1453      if (Tcl_IsShared(last_index)) {
1454        last_index = Tcl_NewIntObj(i);
1455        Tcl_ListObjReplace(NULL, datav[ARG_INDEXES], index_length-1,
1456                           1, 1, &last_index);
1457      } else {
1458        /* set the last value index */
1459        Tcl_SetIntObj( last_index, i );
1460      }
1461      /* to refresh the string */
1462      Tcl_InvalidateStringRep( datav[ ARG_INDEXES ] );
1463      if ( Tcl_IsShared( datav[ ARG_ISFILE ] ) ) {
1464        Tcl_DecrRefCount( datav[ ARG_ISFILE ] );
1465#ifdef ISFILE_IMPLEMENTED
1466        datav[ ARG_ISFILE ] = Tcl_NewIntObj( syn_i->IsFile( ) );
1467#else
1468        datav[ARG_ISFILE] = Tcl_NewIntObj( 0 );
1469#endif
1470        Tcl_IncrRefCount( datav[ ARG_ISFILE ] );
1471      } else
1472#ifdef ISFILE_IMPLEMENTED
1473        Tcl_SetIntObj( datav[ ARG_ISFILE ], syn_i->IsFile( ) );
1474#else
1475      Tcl_SetIntObj( datav[ ARG_ISFILE ], 0 );
1476#endif
1477      /* verify if has subset */
1478      int tmpCard = set_i->Card( );
1479      int j;
1480      for (j=1; j<=tmpCard; ++j )
1481        if ( ContainerGetSet( ( *set_i )[ j ] ) )
1482          break;
1483      if ( Tcl_IsShared( datav[ ARG_HASSUBSET ] ) ) {
1484        Tcl_DecrRefCount( datav[ ARG_HASSUBSET ] );
1485        datav[ ARG_HASSUBSET ] = Tcl_NewIntObj( j <= tmpCard );
1486        Tcl_IncrRefCount( datav[ ARG_HASSUBSET ] );
1487      } else
1488        Tcl_SetIntObj( datav[ ARG_HASSUBSET ], j <= tmpCard );
1489       
1490      /* subtype info */
1491      if ( Tcl_IsShared( datav[ ARG_SUBTYPE ] ) ) {
1492        Tcl_DecrRefCount( datav[ ARG_SUBTYPE ] );
1493        datav[ ARG_SUBTYPE ] = Tcl_NewIntObj( set_i->SubType( ) );
1494        Tcl_IncrRefCount( datav[ ARG_SUBTYPE ] );
1495      } else
1496        Tcl_SetIntObj( datav[ ARG_SUBTYPE ],set_i->SubType( ) );
1497       
1498      /* STRUCT INFO */
1499      if ( set_i->Struct( ) ) {
1500        btxt = set_i->Struct( )->Name( );
1501        Tcl_ExternalToUtfDString( NULL, btxt, -1, &dstr );
1502      }
1503      if ( Tcl_IsShared( datav[ ARG_STRUCT ] ) ) {
1504        Tcl_DecrRefCount( datav[ ARG_STRUCT ] );
1505        datav[ ARG_STRUCT ] = Tcl_NewStringObj( Tcl_DStringValue( &dstr ),-1 );
1506        Tcl_IncrRefCount( datav[ ARG_STRUCT ] );
1507      } else
1508        Tcl_SetStringObj( datav[ ARG_STRUCT ], Tcl_DStringValue( &dstr ),-1 );
1509      Tcl_DStringFree( &dstr );
1510      datac = NUM_ARGS;
1511    } else
1512      datac = ARG_INDEXES;
1513    tcl_code = Tcl_EvalObjv( interp, datac, datav, TCL_EVAL_GLOBAL );
1514    if ( tcl_code == TCL_BREAK ) {
1515      tcl_code = TCL_OK;
1516      break;
1517    }
1518    if ( tcl_code == TCL_ERROR ) {
1519      Tcl_AppendObjToObj( obj_result, Tcl_GetObjResult( interp ) );
1520      break;
1521    }
1522  }
1523 
1524  /* liberar los objetos tcl */
1525  /* OJO aqui tenia ARG_GRAMMAR en lugar de 0 */
1526  for ( i = 0; i < NUM_ARGS; ++i ) {
1527    Tcl_DecrRefCount( datav[ i ] );
1528  }
1529
1530  delete citer;
1531 
1532  delete []datav;
1533  return tcl_code;
1534}
1535
1536/*
1537 * Fill in obj_result the content of the matrix variable.
1538 *
1539 */
1540
1541int Tol_GetMatrixContent(Tcl_Interp * interp,
1542                         Tcl_Obj * obj_name,
1543                         Tcl_Obj * obj_result)
1544{
1545  //BGrammar * gra = NULL;
1546  const BSyntaxObject *tol_obj = NULL;
1547   
1548  if (!(tol_obj=Tol_ResolveObject(interp, obj_name, obj_result))) {
1549    return TCL_ERROR;
1550  }
1551
1552  BMatrix<double> vmat;
1553  BMatrix<double> &theMat = vmat;
1554
1555  if (tol_obj->Grammar()==GraVMatrix()) {
1556    BVMat &V = VMat((BSyntaxObject *)tol_obj);
1557    V.GetDMat(vmat);
1558  } else if (tol_obj->Grammar()==GraMatrix()) {
1559    theMat = ((DMat&)Mat((BSyntaxObject *)tol_obj));
1560  } else { 
1561    Tcl_AppendStringsToObj( obj_result, Tcl_GetString(obj_name),
1562                            " is not a valid Matrix|VMatrix object", NULL );   
1563    return TCL_ERROR;
1564  }
1565   
1566#define IT_NAME 0
1567#define IT_ROWS 1
1568#define IT_COLS 2
1569#define IT_DATA 3
1570#define IT_SIZE 4
1571     
1572  Tcl_Obj * items[4];
1573  Tcl_Obj ** subitems;
1574  int r, Rows, c, Cols;
1575  // BDat & dat = BDat::Unknown();
1576 
1577  //BMatrix<BDat> & mat = (BMatrix<BDat>&)(((BUserMat*)tol_obj)->Contens());
1578 
1579  //items[IT_NAME] = Tcl_NewStringObj(tol_obj->Identify(),-1);
1580  BText tmp;
1581  GetName( tol_obj, tmp );
1582  items[IT_NAME] = Tcl_NewStringObj(tmp.Buffer(),-1);
1583  Rows = theMat.Rows();
1584  Cols = theMat.Columns();
1585  items[IT_ROWS] = Tcl_NewIntObj(Rows);
1586  items[IT_COLS] = Tcl_NewIntObj(Cols);
1587  subitems = (Tcl_Obj**)Tcl_Alloc( sizeof(Tcl_Obj*)*Rows*Cols );
1588  for ( r = 0; r < Rows; ++r )
1589    for ( c = 0; c < Cols; ++c ) {
1590      BDat dat = theMat(r,c);
1591      if (dat.IsKnown())
1592        subitems[r*Cols+c] = Tcl_NewDoubleObj(dat.Value());
1593      else
1594        subitems[r*Cols+c] = Tcl_NewStringObj("?",-1);
1595    }
1596  items[IT_DATA] = Tcl_NewListObj( Rows*Cols, subitems );
1597  Tcl_SetListObj( obj_result,IT_SIZE, items );
1598  Tcl_Free( (char*)subitems );
1599  return TCL_OK;
1600}
1601
1602/*
1603 * Fill in obj_result the content of the serie variable.
1604 *
1605 */
1606
1607int Tol_GetSerieContent(Tcl_Interp * interp,
1608                        int objc,
1609                        Tcl_Obj *CONST objv[],
1610                        Tcl_Obj * obj_result)
1611{
1612  const BSyntaxObject* var = Tol_ResolveObject(interp,
1613                                               objv[0],
1614                                               obj_result/*,
1615                                               GraSerie()*/);
1616  if (!var) {
1617    return TCL_ERROR;
1618  }
1619
1620  // parse dates arguments
1621 
1622  BDate I0, I1;
1623  int tcl_code;
1624
1625  BUserTimeSerie * serie = (BUserTimeSerie*)var;
1626  serie->ReadData();
1627
1628  if (objc == 1) {
1629    I0 = serie->FirstDate();
1630    I1 = serie->LastDate();
1631  } else {
1632    tcl_code = Tol_ParseDate(interp,Tcl_GetString(objv[1]),I0);
1633    if (tcl_code != TCL_OK) {
1634      Tcl_AppendObjToObj(obj_result,Tcl_GetObjResult(interp));
1635      return TCL_ERROR;
1636    }
1637    if (objc == 3) {
1638      tcl_code = Tol_ParseDate(interp,Tcl_GetString(objv[2]),I1);
1639      if (tcl_code != TCL_OK) {
1640        Tcl_AppendObjToObj(obj_result,Tcl_GetObjResult(interp));
1641        return TCL_ERROR;
1642      }
1643    }
1644  }
1645 
1646  if ( !I0.HasValue() )
1647    I0 = BDate::DefaultFirst();
1648  if ( !I1.HasValue() )
1649    I1 = BDate::DefaultLast();
1650
1651  BUserTimeSet * tms;
1652  Tcl_Obj ** obj_array;
1653  int length;
1654
1655  char buffer[1024];
1656
1657  tms = serie->Dating();
1658
1659  if ( !tms ) {
1660    Tcl_AppendStringsToObj(obj_result,"Serie \"",
1661                           Tcl_GetString(objv[0]),
1662                           "\" does not have dating", NULL);
1663    return TCL_ERROR;
1664  }
1665
1666  // ajustamos el intervalo de fechas al fechado
1667
1668  I0 = tms->FirstNoLess(I0);
1669  I1 = tms->FirstNoGreat(I1);
1670  length = tms->Difference(I0,I1)+1;
1671  if ( length <= 0 ) {
1672    Tcl_SetStringObj(obj_result,
1673                     "last date must be greater or equal than first",-1);
1674    return TCL_ERROR;
1675  }
1676
1677  BDat  value;
1678  BText tmp;
1679  Tcl_Obj * subitems[2];
1680
1681  // ++ because we identify the TimeSet as the first element
1682
1683  ++length;
1684  obj_array = (Tcl_Obj**)ckalloc(length*sizeof(Tcl_Obj*));
1685
1686  //tmp = tms->Identify();
1687  GetName(tms, tmp);
1688  obj_array[0] = Tcl_NewStringObj(tmp,-1);
1689  for ( int i = 1; i < length; i++ ) {
1690    tmp = I0.GetText();
1691    subitems[0] = Tcl_NewStringObj(tmp,-1);
1692#if defined(_TOL_FROZEN_)
1693    value = (*serie)[I0];
1694#else
1695    value = (*serie)(I0);
1696#endif
1697    if ( value.IsKnown() )
1698      subitems[1] = Tcl_NewDoubleObj(value.Value());
1699    else
1700      subitems[1] = Tcl_NewStringObj("?",-1);
1701    obj_array[i] = Tcl_NewListObj(2,subitems);
1702    I0 += tms;
1703
1704    sprintf(buffer,"%d",i);
1705    Tcl_VarEval(interp, "puts ", buffer, NULL);
1706  }
1707  Tcl_SetListObj(obj_result,length,obj_array);
1708  Tcl_Free( (char*)obj_array );
1709  return TCL_OK;
1710}
1711
1712int Tol_ParseDate(Tcl_Interp * interp, char * what, BDate & date)
1713{
1714  int    year, month, day, hour, min;
1715  double sec;
1716 
1717  int tcl_code;
1718  Tcl_Obj * tcl_result;
1719  int objc;
1720  Tcl_Obj ** objv;
1721
1722  month = day = 1;
1723  hour  = min = 0;
1724  sec   = 0.0;
1725  char re_pat[] = "{^(?:y([0-9]+)(?:m([0-9]+))?(?:d([0-9]+))?)$}";
1726
1727  tcl_code = Tcl_VarEval(interp, "regexp -inline ", re_pat, " ",what, NULL);
1728  if ( tcl_code != TCL_OK )
1729    return TCL_ERROR;
1730  tcl_result = Tcl_DuplicateObj(Tcl_GetObjResult(interp));
1731  /* this should be a valid list, unless Tcl be corrupt */
1732  Tcl_ListObjGetElements(interp,tcl_result,&objc,&objv);
1733  if ( objc == 0 ) {
1734    Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
1735                           "invalid date: \"",what,"\"",NULL);
1736    Tcl_DecrRefCount(tcl_result);
1737    return TCL_ERROR;
1738  }
1739
1740  /* and objc must be 4 */
1741
1742  Tcl_GetIntFromObj(interp,objv[1],&year);
1743  Tcl_GetIntFromObj(interp,objv[2],&month);
1744  Tcl_GetIntFromObj(interp,objv[3],&day);
1745
1746  /* now is save to release tcl_result */
1747
1748  Tcl_DecrRefCount(tcl_result);
1749
1750  date.PutDate(year,month,day);
1751  if ( !date.HasValue() ) {
1752    Tcl_ResetResult(interp);
1753    char buffer[1024];
1754    sprintf(buffer,"y%dm%dd%d",year,month,day);
1755    tcl_result = Tcl_GetObjResult(interp);
1756    Tcl_AppendStringsToObj(tcl_result,
1757                           what," = ",buffer," is valid but unknown",NULL);
1758    return TCL_ERROR;
1759  }
1760  return TCL_OK;
1761}
1762
1763/*
1764 * Set the language to be used  by TOL. Fill in obj_result the previous
1765 * language.
1766 *
1767 */
1768
1769int Tol_SetLanguage(Tcl_Interp * interp, Tcl_Obj * lang, Tcl_Obj * obj_result)
1770{
1771  BBool curLang = BText::Language();
1772  BIdiomEnum nextLang;
1773 
1774  char * strLang = Tcl_GetString( lang );
1775  if ( !strcasecmp( strLang, "es" ) )
1776    nextLang = BSPANISH;
1777  else {
1778    /* anything else will be assumed as english */
1779    nextLang = BENGLISH;
1780  }
1781  /* set the previous language as result */
1782  if ( curLang == BSPANISH )
1783    Tcl_SetStringObj( obj_result, "es", -1 );
1784  else
1785    Tcl_SetStringObj( obj_result, "en", -1 );
1786  /* tell TOL what language to use from now on */
1787  BText::PutLanguage( nextLang );
1788  return TCL_OK;
1789}
1790
1791/*
1792 * Return the language used  by TOL. Fill in obj_result the current
1793 * language.
1794 *
1795 */
1796
1797int Tol_GetLanguage(Tcl_Interp * interp, Tcl_Obj * obj_result)
1798{
1799  BBool curLang = BText::Language();
1800 
1801  if ( curLang == BSPANISH )
1802    Tcl_SetStringObj( obj_result, "es", -1 );
1803  else
1804    Tcl_SetStringObj( obj_result, "en", -1 );
1805  return TCL_OK;
1806}
1807
1808/*
1809 * Fill in obj_result the version info corresponding to tol
1810 *
1811 *   {major MajorNum minor MinorNum release ReleaseNum coment Comment}
1812 *
1813 */
1814
1815int Tol_InfoVersion( Tcl_Interp * interp,  Tcl_Obj * obj_result )
1816{
1817#define VERSION_INFO_SIZE 3*2
1818 
1819  Tcl_Obj * items[VERSION_INFO_SIZE];
1820  char buffer[64];
1821
1822  /* Major Info */
1823  items[0] = Tcl_NewStringObj( "major", -1 );
1824  items[1] = Tcl_NewIntObj( VERSION_MAJOR );
1825  /* Minor Info */
1826  items[2] = Tcl_NewStringObj( "minor", -1 );
1827  items[3] = Tcl_NewIntObj( VERSION_MINOR );
1828  /* Comment Info */
1829  items[4] = Tcl_NewStringObj( "comment", -1 );
1830  items[5] = Tcl_NewStringObj(TOLVersionBuild(), -1 );
1831  /* asign the items to the result list */
1832  Tcl_SetListObj( obj_result, VERSION_INFO_SIZE, items );
1833  return TCL_OK;
1834}
1835
1836/*
1837 * Fill in obj_result the list of files included in TOL
1838 *
1839 */
1840
1841
1842int Tol_InfoIncluded (Tcl_Interp * interp,Tcl_Obj * obj_result)
1843{
1844  BList* lst = BSetFromFile::Compiled();
1845
1846  BText txt(LstText(lst,"","",","));
1847  return BList2TclList(interp,lst,obj_result,&GetPath,&HasNoSource);
1848}
1849
1850/* OJO con la declaracion de tmpSet */
1851
1852int Tol_InfoFile(Tcl_Interp * interp, Tcl_Obj * file,
1853                 Tcl_Obj * obj_result)
1854{
1855  Tcl_DString dstr;
1856  const BSyntaxObject * so;
1857
1858  Tcl_DStringInit(&dstr);
1859  Tcl_UtfToExternalDString(NULL,Tcl_GetString(file),-1,&dstr);
1860 
1861  BText fname(Tcl_DStringValue(&dstr));
1862  so = (const BSyntaxObject*)BSetFromFile::FindCompiled(fname);
1863  Tcl_DStringFree(&dstr);
1864  if (!so) {
1865    Tcl_AppendStringsToObj(obj_result,"file \"",
1866                           Tcl_GetString(file),
1867                           "\" isn't included", NULL );
1868    return TCL_ERROR;
1869  }
1870  Tcl_Obj * info[6];
1871  /* adicionar la informacion del subtype y si tiene algun set
1872   * como descendiente
1873   */
1874  BText soInfo(so->Info());
1875  BText soPath(so->SourcePath());
1876  BText soDesc(so->Description());
1877
1878  char * pch = soInfo;
1879  if (pch) pch = skipWhite(pch);
1880  else pch = (char*)"";
1881
1882  Tcl_ExternalToUtfDString(NULL,pch,-1,&dstr);
1883  info[0] = Tcl_NewStringObj(Tcl_DStringValue(&dstr), -1);
1884  Tcl_DStringFree(&dstr);
1885
1886  Tcl_ExternalToUtfDString(NULL,soPath,-1,&dstr);
1887  info[1] = Tcl_NewStringObj(Tcl_DStringValue(&dstr), -1);
1888  Tcl_DStringFree(&dstr);
1889
1890  Tcl_ExternalToUtfDString(NULL,soDesc,-1,&dstr);
1891  info[2] = Tcl_NewStringObj(Tcl_DStringValue(&dstr), -1);
1892  Tcl_DStringFree(&dstr);
1893
1894  /* HAS SUBSET */
1895  BSet * ptrSet = &(((BUserSet*)so)->Contens());
1896  int tmpCard = ptrSet->Card();
1897  int j;
1898  for (j=1; j<=tmpCard; ++j )
1899    if (ContainerGetSet((*ptrSet)[j]))
1900      break;
1901  info[3] = Tcl_NewIntObj(j<=tmpCard);
1902   
1903  /* SUBTYPE INFO */
1904  info[4] = Tcl_NewIntObj( ptrSet->SubType() );
1905  /* STRUCTURE */
1906  info[5] = Tcl_NewStringObj( NULL, 0 );
1907  Tcl_SetListObj(obj_result, 6, info);
1908  return TCL_OK;
1909}
1910
1911int Tol_CheckSyntax(Tcl_Interp * interp,
1912                    Tcl_Obj    * obj_expr,
1913                    Tcl_Obj    * obj_result)
1914{
1915  Tcl_DString dstr;
1916  BText tol_expr;
1917
1918  Tcl_DStringInit(&dstr);
1919  tol_expr = Tcl_UtfToExternalDString( NULL, Tcl_GetString( obj_expr ),
1920                                       -1, &dstr );
1921  Tcl_DStringFree(&dstr);
1922  BText result = CheckSyntax( tol_expr );
1923  Tcl_SetStringObj( obj_result, result.String(), -1 );
1924  return TCL_OK;
1925}
1926
1927/*
1928 * Fill in obj_result the result of evaluating including the file
1929 * given as argument: the absolute path.
1930 *
1931 */
1932
1933int Tol_IncludeFile(Tcl_Interp * interp,Tcl_Obj * obj_file,Tcl_Obj * obj_result)
1934{
1935  Tcl_DString dstr;
1936  BText fName;
1937
1938  Tcl_DStringInit(&dstr);
1939  fName = Tcl_UtfToExternalDString(NULL,Tcl_GetString(obj_file),-1,&dstr);
1940  BSetFromFile* uSet = (BSetFromFile*)BSetFromFile::FindCompiled(fName);
1941  Tcl_DStringFree(&dstr);
1942
1943  if(uSet) {
1944    DESTROY(uSet);
1945  }
1946  IncludeFile(fName);
1947  return TCL_OK;
1948}
1949
1950int Tol_DecompileFile( Tcl_Interp * interp,
1951                       Tcl_Obj * obj_file,
1952                       Tcl_Obj * obj_result )
1953{
1954  Tcl_DString dstr;
1955  BText fName;
1956
1957  Tcl_DStringInit(&dstr);
1958  fName = Tcl_UtfToExternalDString(NULL,Tcl_GetString(obj_file),-1,&dstr);
1959  BSetFromFile* uSet = (BSetFromFile*)BSetFromFile::FindCompiled(fName);
1960  Tcl_DStringFree(&dstr);
1961
1962  if(uSet) {
1963    DESTROY(uSet);
1964  } else {
1965    Tcl_AppendStringsToObj( obj_result, "file '",
1966                            Tcl_GetString(obj_file),
1967                            "' is not compiled", NULL );
1968    return TCL_ERROR;
1969  }
1970  if ( uSet ) {
1971    Tcl_AppendStringsToObj( obj_result, "could not decompile file '",
1972                            Tcl_GetString(obj_file), "'", NULL );
1973    return TCL_ERROR;
1974  }
1975  return TCL_OK;
1976}
1977
1978/*
1979 *
1980 * Fill in obj_result the list of grammars defined in TOL
1981 *
1982 */
1983int Tol_SetGrammarsObj(Tcl_Interp * interp, Tcl_Obj * obj_result )
1984{
1985
1986  BList* lstGra = BGrammar::Instances();
1987
1988  if (BList2TclList(interp,lstGra,obj_result,&GetName,&ExcludeAnything)==TCL_OK) {
1989    Tcl_Obj * name = Tcl_NewStringObj("Anything", -1);
1990    if (Tcl_ListObjAppendElement(interp,obj_result,name) != TCL_OK) {
1991      Tcl_AppendObjToObj(obj_result,Tcl_GetObjResult(interp));
1992      return TCL_ERROR;
1993    }
1994    if (QuickSort(interp,obj_result) != TCL_OK) {
1995      Tcl_AppendObjToObj(obj_result,Tcl_GetObjResult(interp));
1996      return TCL_ERROR;
1997    }
1998    return TCL_OK;
1999  }
2000  Tcl_AppendObjToObj(obj_result,Tcl_GetObjResult(interp));
2001  return TCL_ERROR;
2002}
2003
2004/*
2005 *
2006 * Fill in obj_result the description of gra_name.
2007 *
2008 */
2009
2010int Tol_SetGrammarDescObj(Tcl_Interp * interp, Tcl_Obj * gra_name,
2011                          Tcl_Obj * obj_result )
2012{
2013  BGrammar * gra = BGrammar::FindByName(Tcl_GetString(gra_name));
2014
2015  if (gra) {
2016    BText desc(gra->Description());
2017    Tcl_SetStringObj(obj_result, desc, -1);
2018    return TCL_OK;
2019  }
2020  Tcl_AppendStringsToObj( obj_result, "\"",
2021                          Tcl_GetString(gra_name),
2022                          "\" isn't a grammar", NULL );
2023  return TCL_ERROR;
2024}
2025
2026/*
2027 *
2028 * Fill in obj_result the list of packages defined in TOL
2029 *
2030 */
2031int Tol_SetPackagesObj(Tcl_Interp * interp, Tcl_Obj * obj_result )
2032{
2033
2034  BList* lstGra = BPackage::Required();
2035
2036  BList2TclList( interp, lstGra, obj_result, &GetName );
2037  Tcl_AppendObjToObj( obj_result, Tcl_GetObjResult( interp ) );
2038  return TCL_OK;
2039}
2040
2041/*
2042 *
2043 * Fill in obj_result the description of package.
2044 *
2045 */
2046int Tol_SetPackageDescObj( Tcl_Interp *interp, Tcl_Obj *pkgName,
2047                           Tcl_Obj *obj_result )
2048{
2049  int status;
2050  Tcl_Obj *graName = Tcl_NewStringObj( "NameBlock", -1 );
2051 
2052  status = Tol_SetVariableInfoObj( graName, pkgName, obj_result );
2053  Tcl_DecrRefCount( graName );
2054  return status;
2055}
2056
2057/*
2058 *  Tol_FillFunctionInfo --
2059 *
2060 *    Used in Tol_SetFunctionsObj & Tol_SetFunctionInfoObj to return the info
2061 *    for the function requested.
2062 */
2063
2064static
2065int Tol_FillFunctionInfo(BOperator * opr, Tcl_Obj * obj_result)
2066{
2067  Tcl_Obj * info[3];
2068  Tcl_DString dstr_info;
2069  Tcl_DString dstr;
2070
2071  Tcl_DStringInit(&dstr_info);
2072  BText args(opr->Arguments());
2073 
2074  if(args.Last()!='}') // name doesn't comes within the arguments expression
2075  {   
2076      // grammar name
2077      Tcl_DStringAppend(&dstr_info, opr->Grammar()->Name(), -1);
2078      Tcl_DStringAppend(&dstr_info, " ", -1);
2079      // function name
2080      Tcl_DStringInit(&dstr);
2081      // antes estaba FullName
2082      Tcl_ExternalToUtfDString(NULL, opr->FullName(), -1, &dstr);
2083      Tcl_DStringAppend(&dstr_info, Tcl_DStringValue(&dstr), -1);
2084      Tcl_DStringFree(&dstr);
2085  }
2086
2087  Tcl_ExternalToUtfDString(NULL,args.String(),-1,&dstr);
2088  Tcl_DStringAppend(&dstr_info, Tcl_DStringValue(&dstr), -1);
2089  Tcl_DStringFree(&dstr);
2090  info[0] = Tcl_NewStringObj(Tcl_DStringValue(&dstr_info), -1);
2091  Tcl_DStringFree(&dstr_info);
2092  Tcl_ExternalToUtfDString(NULL,opr->SourcePath(),-1,&dstr);
2093  info[1] = Tcl_NewStringObj(Tcl_DStringValue(&dstr), -1);
2094  Tcl_DStringFree(&dstr);
2095  Tcl_ExternalToUtfDString(NULL,opr->Description(),-1,&dstr);
2096  info[2] = Tcl_NewStringObj(Tcl_DStringValue(&dstr), -1);
2097  Tcl_DStringFree(&dstr);
2098  Tcl_SetListObj(obj_result, 3, info);
2099  return TCL_OK;
2100}
2101
2102/*
2103 *
2104 * Fill in obj_result the functions defined for grammar gra_name.  If gra_name
2105 * is a list it is considered as an object reference {type ?name? i1 ... ik}
2106 *
2107 */
2108
2109int Tol_SetFunctionsObj (Tcl_Interp * interp, Tcl_Obj * gra_name,
2110                         Tcl_Obj * obj_result)
2111{
2112  int length = 0;
2113 
2114  if (Tcl_ListObjLength(interp,gra_name,&length)!=TCL_OK) {
2115    Tcl_AppendObjToObj(obj_result,Tcl_GetObjResult(interp));
2116    return TCL_ERROR;
2117  }
2118  if (length>1) {
2119    const BSyntaxObject *syn;
2120    if (!(syn=Tol_ResolveObject(interp, gra_name, obj_result))) {
2121      return TCL_ERROR;
2122    }
2123   
2124    if (syn->Grammar() != GraCode()) {
2125      Tcl_AppendStringsToObj(obj_result, "'", Tcl_GetString(gra_name),
2126                             "' is not a function object", NULL);
2127      return TCL_ERROR;
2128    }
2129    BOperator * opr =  ((BGraContens<BCode>*)syn)->Contens().Operator();
2130    return Tol_FillFunctionInfo(opr, obj_result);
2131  }
2132  /* gra_name should be a grammar name */
2133  if (!strcmp(Tcl_GetString(gra_name), "Anything")) {
2134    const BSpFunHash& spf = BSpecialFunction::Instances();
2135    BSpFunHash::const_iterator iter;
2136    for(iter=spf.begin(); iter!=spf.end(); iter++)
2137    {
2138      Tcl_ListObjAppendElement(interp, obj_result,
2139                               Tcl_NewStringObj(iter->second->Name(), -1));
2140    }
2141    if (QuickSort(interp,obj_result) != TCL_OK) {
2142      Tcl_AppendObjToObj(obj_result,Tcl_GetObjResult(interp));
2143      return TCL_ERROR;
2144    }
2145    return TCL_OK;
2146  }
2147
2148  BGrammar * gra = BGrammar::FindByName(Tcl_GetString(gra_name));
2149 
2150  if (gra) {
2151    BList * lstOper = gra->GetOperators();
2152    if (BList2TclList(interp,lstOper,obj_result,&GetFullName) != TCL_OK) {
2153      Tcl_AppendObjToObj(obj_result,Tcl_GetObjResult(interp));
2154      DESTROY(lstOper);
2155      return TCL_ERROR;
2156    }
2157    DESTROY(lstOper);
2158    if (QuickSort(interp,obj_result) != TCL_OK) {
2159      Tcl_AppendObjToObj(obj_result,Tcl_GetObjResult(interp));
2160      return TCL_ERROR;
2161    }
2162    return TCL_OK;
2163  }
2164
2165  Tcl_AppendStringsToObj(obj_result, "'",
2166                         Tcl_GetString(gra_name),
2167                         "' isn't a grammar", NULL);
2168  return TCL_ERROR;
2169}
2170
2171static
2172BOperator* TT_FindOperator( const BGrammar *G, const char *expr )
2173{
2174  BOperator* opr = G->FindOperator( expr );
2175  if ( opr ) {
2176    return opr;
2177  }
2178  bool oldEnabled = BOut::Disable();
2179  bool stopFlag = BGrammar::StopFlag();
2180  BGrammar::Turn_StopFlag_Off();
2181  BSyntaxObject* obj = GraCode( )->BGrammar::LeftEvaluateExpr( expr );
2182  if ( stopFlag ) {
2183    BGrammar::Turn_StopFlag_On();
2184  } else {
2185    BGrammar::Turn_StopFlag_Off();
2186  }
2187  if( oldEnabled ) { BOut::Enable( ); }
2188  if(obj)
2189  {
2190    if( obj->Mode( ) == BUSERFUNMODE )
2191    {
2192      opr = dynamic_cast<BOperator*>( obj );
2193    }   
2194    if( obj->Mode( ) == BOBJECTMODE )
2195    {
2196      BUserCode *uc = dynamic_cast<BUserCode*>( obj );
2197      opr = uc ? uc->Contens().Operator( ) : NULL;
2198      if( opr && ( opr->Grammar( ) != G ) ) { opr = NULL; }
2199    }
2200  }
2201  return( opr );
2202}
2203
2204/*
2205 * Fill in obj_result the function's prototype and description
2206 * for a given function in a given grammar.
2207 *
2208 */
2209
2210int Tol_SetFunctionInfoObj (Tcl_Obj * gra_name,
2211                            Tcl_Obj * fun_name,
2212                            Tcl_Obj * obj_result)
2213{
2214  Tcl_DString dstr;
2215  Tcl_Obj * info[3];
2216
2217  if (!strcmp(Tcl_GetString(gra_name), "Anything")) {
2218    Tcl_DStringInit(&dstr);
2219    Tcl_UtfToExternalDString(NULL,Tcl_GetString(fun_name),-1,&dstr);
2220    const BSpecialFunction * spf = BSpecialFunction::Get(Tcl_DStringValue(&dstr));
2221    Tcl_DStringFree(&dstr);
2222    if (spf) {
2223      char * name, * args;
2224      size_t len;
2225     
2226      name = ((BText&)spf->Name()).Buffer();
2227      args = ((BText&)spf->Arguments()).Buffer();
2228      len = strlen(args);
2229      if(!len || args[len-1]!='}') {
2230        info[0] = Tcl_NewStringObj("Anything ", -1);
2231        Tcl_AppendStringsToObj(info[0],name,args,NULL);
2232      } else {
2233        info[0] = Tcl_NewStringObj("", -1);;
2234        Tcl_AppendStringsToObj(info[0],args,NULL);
2235      }
2236      info[1] = Tcl_NewStringObj("",-1);
2237      Tcl_ExternalToUtfDString(NULL,spf->Description(),-1,&dstr);
2238      info[2] = Tcl_NewStringObj(Tcl_DStringValue(&dstr), -1);
2239      Tcl_DStringFree(&dstr);
2240      Tcl_SetListObj(obj_result, 3, info);
2241      return TCL_OK;
2242    }
2243    Tcl_AppendStringsToObj( obj_result, "\"",
2244                            Tcl_GetString(fun_name),
2245                            "\" isn't a function in grammar Anything", NULL );
2246  } else {
2247    BGrammar * gra = BGrammar::FindByName(Tcl_GetString(gra_name));
2248 
2249    if (gra) {
2250      Tcl_DStringInit(&dstr);
2251      Tcl_UtfToExternalDString( NULL, Tcl_GetString( fun_name ), -1, &dstr );
2252      BOperator* opr = TT_FindOperator( gra, Tcl_DStringValue( &dstr ) );
2253      Tcl_DStringFree(&dstr);
2254      if (opr) {
2255        return Tol_FillFunctionInfo(opr, obj_result);
2256      }
2257      // release the previous use of dstr
2258      //Tcl_DStringFree(&dstr);
2259      Tcl_AppendStringsToObj( obj_result, "\"",
2260                              Tcl_GetString(fun_name),
2261                              "\" isn't a function in grammar ",
2262                              Tcl_GetString(gra_name), NULL );
2263    } else
2264      Tcl_AppendStringsToObj( obj_result, "\"",
2265                              Tcl_GetString(gra_name),
2266                              "\" isn't a grammar", NULL );
2267  }
2268  return TCL_ERROR;
2269}
2270
2271/* ojo info debe tener espacio para 9 Tcl_Obj como maximo */
2272/* retorna cuantos Tcl_Obj creo */
2273
2274int SynObj2TclObj( const BSyntaxObject * var, Tcl_Obj * info[] )
2275{
2276  Tcl_DString dstr;
2277  int infoc;
2278
2279  Tcl_DStringInit(&dstr);
2280
2281  /* GRAMMAR */
2282#ifdef ISFILE_IMPLEMENTED
2283  info[ 0 ] = Tcl_NewStringObj(var->IsFile( ) ? "File" :
2284                               var->Grammar( )->Name( ).String( ), -1 );
2285#else
2286  info[ 0 ] = Tcl_NewStringObj( var->Grammar( )->Name( ).String( ), -1 );
2287#endif
2288   
2289  /* NAME */
2290  BText synname;
2291 
2292  GetName(var, synname);
2293  Tcl_ExternalToUtfDString(NULL,synname,-1,&dstr);
2294  info[1] = Tcl_NewStringObj(Tcl_DStringValue(&dstr), -1);
2295  Tcl_DStringFree(&dstr);
2296   
2297  /* REST OF FIELDS */
2298 
2299  BText varInfo(var->Info());
2300  BText varPath(var->SourcePath());
2301  BText varDesc(var->Description());
2302 
2303  /* OBJECT CONTENT */
2304  char * pch = varInfo;
2305 
2306  if (pch) pch = skipWhite(pch);
2307  else pch = (char*)"";
2308 
2309  Tcl_ExternalToUtfDString(NULL,pch,-1,&dstr);
2310  info[2] = Tcl_NewStringObj(Tcl_DStringValue(&dstr), -1);
2311  Tcl_DStringFree(&dstr);
2312 
2313  /* OBJECT PATH */
2314  Tcl_ExternalToUtfDString(NULL,varPath,-1,&dstr);
2315  info[3] = Tcl_NewStringObj(Tcl_DStringValue(&dstr), -1);
2316  Tcl_DStringFree(&dstr);
2317 
2318  /* OBJECT DESCRIPTION */
2319  Tcl_ExternalToUtfDString(NULL,varDesc,-1,&dstr);
2320  info[4] = Tcl_NewStringObj(Tcl_DStringValue(&dstr), -1);
2321  Tcl_DStringFree(&dstr);
2322 
2323#ifdef ISFILE_IMPLEMENTED
2324  info[5] = Tcl_NewIntObj(var->IsFile());
2325#else
2326  info[5] = Tcl_NewIntObj(0);
2327#endif
2328  //info[6] = Tcl_NewIntObj(var->System());
2329  BSet *ptrSet;
2330  if ((ptrSet=ContainerGetSet(var))) {
2331    /* HAS SUBSET */
2332    int tmpCard = ptrSet->Card();
2333    int j;
2334    for (j=1; j<=tmpCard; ++j )
2335      if ( (*ptrSet)[j]->Grammar()==GraSet() )
2336        break;
2337    info[6] = Tcl_NewIntObj(j<=tmpCard);
2338     
2339    /* SUBTYPE */
2340    info[7] = Tcl_NewIntObj( ptrSet->SubType() );
2341     
2342    /* STRUCTURE */
2343    if ( var->Grammar() == GraNameBlock() ) {
2344      const BNameBlock& nb = ((BUserNameBlock*)(var))->Contens();
2345      const BClass* cls = nb.Class( );
2346      if ( cls ) {
2347        info[8] = Tcl_NewStringObj( cls->FullName().String(), -1 );
2348      } else {
2349        info[8] = Tcl_NewStringObj( NULL, 0 );
2350      }
2351    } else if ( ptrSet->Struct() ) {
2352      BText btxt( ptrSet->Struct()->Name() );
2353      Tcl_ExternalToUtfDString(NULL,btxt,-1,&dstr);
2354      info[8] = Tcl_NewStringObj( Tcl_DStringValue(&dstr), -1 );
2355      Tcl_DStringFree( &dstr );
2356    } else {
2357      info[8] = Tcl_NewStringObj( NULL, 0 );
2358    }
2359    infoc = 9;
2360  } else
2361    infoc = 6;
2362 
2363  return infoc;
2364}
2365
2366int Tol_SetVariableInfoObj (Tcl_Obj * gra_name,
2367                            Tcl_Obj * var_name,
2368                            Tcl_Obj * obj_result);
2369
2370/*!
2371 * Fill in obj_result the variables defined for grammar gra_name.
2372 * Or the element info if gra_name is a reference of an element
2373 * of a global container.
2374 */
2375int Tol_SetVariablesObj (Tcl_Interp *interp, Tcl_Obj *obj_reference,
2376                         Tcl_Obj *obj_result)
2377{
2378  const BSyntaxObject *syn ;
2379 
2380  int length = 0;
2381  Tcl_Obj ** items;
2382  int tcl_code;
2383 
2384  if ( Tcl_ListObjLength( interp, obj_reference, &length ) != TCL_OK ) {
2385    Tcl_AppendObjToObj( obj_result, Tcl_GetObjResult( interp ) );
2386    return TCL_ERROR;
2387  }
2388  if ( length > 1 ) {
2389    /*
2390    if (length == 2) {
2391      tcl_code = Tcl_ListObjGetElements(interp,obj_reference,&length,&items);
2392      assert(tcl_code == TCL_OK);
2393      if (strcmp(Tcl_GetString(items[0]),"Console"))
2394        return Tol_SetVariableInfoObj(items[0], items[1], obj_result);
2395    }
2396    */
2397    if ( !( syn = Tol_ResolveObject( interp, obj_reference, obj_result ) ) ) {
2398      return TCL_ERROR;
2399    }
2400//    Tcl_DString dstr;
2401    Tcl_Obj * info[9];
2402    int infoc;
2403   
2404    infoc = SynObj2TclObj(syn, info);
2405    Tcl_SetListObj(obj_result,infoc,info);
2406    return TCL_OK;
2407  }
2408  BGrammar *gra = BGrammar::FindByName(Tcl_GetString( obj_reference ) );
2409  if (!gra) {
2410    Tcl_AppendStringsToObj( obj_result, "'",
2411                            Tcl_GetString( obj_reference ),
2412                            "' isn't a grammar", NULL );
2413    return TCL_ERROR;
2414  }
2415  BList * lstVar = gra->GetVariables();
2416  if (BList2TclList(interp,lstVar,obj_result,&GetIdentify) != TCL_OK) {
2417    Tcl_AppendObjToObj(obj_result,Tcl_GetObjResult(interp));
2418    DESTROY(lstVar);
2419    return TCL_ERROR;
2420  }
2421  DESTROY(lstVar);
2422  if (QuickSort(interp,obj_result) != TCL_OK) {
2423    Tcl_AppendObjToObj(obj_result,Tcl_GetObjResult(interp));
2424    return TCL_ERROR;
2425  }
2426  return TCL_OK;
2427}
2428
2429/*
2430 * Fill in obj_result the variables's description for a given variable
2431 * in a given grammar.
2432 *
2433 */
2434
2435int Tol_SetVariableInfoObj (Tcl_Obj * gra_name,
2436                            Tcl_Obj * var_name,
2437                            Tcl_Obj * obj_result)
2438{
2439  BGrammar * gra = BGrammar::FindByName(Tcl_GetString(gra_name));
2440  Tcl_DString dstr;
2441 
2442  Tcl_DStringInit(&dstr);
2443  if (gra) {
2444    Tcl_UtfToExternalDString(NULL,Tcl_GetString(var_name),-1,&dstr);
2445    const BSyntaxObject* var = gra->FINDVARIABLE(Tcl_DStringValue(&dstr));
2446    Tcl_DStringFree(&dstr);
2447
2448    if (var) {
2449      Tcl_Obj * info[9];
2450      int infoc;
2451      infoc = SynObj2TclObj( var, info );
2452      Tcl_SetListObj(obj_result,infoc,info);
2453//#define __INFO_PRINT_NREFS__
2454#ifdef __INFO_PRINT_NREFS__
2455      printf("NREF = %d\n", var->NRefs());
2456#endif
2457      return TCL_OK;
2458    }
2459    Tcl_AppendStringsToObj( obj_result, "\"",
2460                            Tcl_GetString(var_name),
2461                            "\" isn't a variable in grammar ",
2462                            Tcl_GetString(gra_name), NULL );
2463  } else
2464    Tcl_AppendStringsToObj( obj_result, "\"",
2465                            Tcl_GetString(gra_name),
2466                            "\" isn't a grammar", NULL );
2467  return TCL_ERROR;
2468}
2469
2470/*
2471 * Fill in obj_result the string representation of the
2472 * address of the object referenced in obj_ref.
2473 */
2474int Tol_GetAddressFromObject( Tcl_Interp * interp,
2475                             Tcl_Obj * obj_ref,
2476                             Tcl_Obj * obj_result)
2477{
2478  const BSyntaxObject *syn ;
2479
2480#ifndef _NDEBUG
2481  //#define _PRINT_ADDR_OBJREF_
2482#endif
2483
2484#ifdef _PRINT_ADDR_OBJREF_
2485  printf( "obj_ref = %s\n", Tcl_GetString( obj_ref ) );
2486#endif
2487
2488  if ( !( syn = Tol_ResolveObject( interp, obj_ref, obj_result ) ) ) {
2489    return TCL_ERROR;
2490  }
2491  BText addr = syn->GetAddressFromObject( );
2492  Tcl_SetStringObj( obj_result, addr.Buffer( ), -1 );
2493  return TCL_OK;
2494}
2495                           
2496/*
2497 * Fill in obj_result the specific type for an Anything object, could
2498 * be: Struct, Class or Anything.
2499 */
2500int Tol_GetAnythingType( Tcl_Interp * interp,
2501                         Tcl_Obj * obj_ref,
2502                         Tcl_Obj * obj_result)
2503{
2504  const BSyntaxObject *syn ;
2505
2506#ifndef _NDEBUG
2507  //#define _PRINT_ANYTHING_OBJREF_
2508#endif
2509
2510#ifdef _PRINT_ANYTHING_OBJREF_
2511  printf( "obj_ref = %s\n", Tcl_GetString( obj_ref ) );
2512#endif
2513
2514  if ( !( syn = Tol_ResolveObject( interp, obj_ref, obj_result ) ) ) {
2515    return TCL_ERROR;
2516  }
2517 
2518  if ( syn->Mode() == BCLASSMODE ) {
2519    Tcl_SetStringObj( obj_result, "Class", -1 );
2520  } else if ( syn->Mode() == BSTRUCTMODE ) {
2521    Tcl_SetStringObj( obj_result, "Struct", -1 );
2522  } else {
2523    Tcl_SetStringObj( obj_result, "Anything", -1 );
2524  }
2525  return TCL_OK;
2526}
2527                           
2528/*
2529 * We must be sure that the strings use 7 bit ASCII chararters.
2530 * Otherwise we must take care of the Utf representation.
2531 *
2532 */
2533
2534static
2535int StrObjCompare(const void * O1, const void * O2)
2536{
2537  char * str1 = (*(Tcl_Obj**)O1)->bytes;
2538  char * str2 = (*(Tcl_Obj**)O2)->bytes;
2539  int check1, check2;
2540
2541  check1 = isalpha(str1[0]);
2542  check2 = isalpha(str2[0]);
2543
2544  if ( check1 && !check2 )
2545    return 1;
2546  if ( check2 && !check1 )
2547    return -1;
2548  return strcmp(str1,str2);
2549}
2550
2551static
2552int QuickSort( Tcl_Interp * interp, Tcl_Obj * list )
2553{
2554  Tcl_Obj ** obj_array;
2555  int length;
2556
2557  if (Tcl_ListObjGetElements(interp, list, &length, &obj_array) != TCL_OK) {
2558    return TCL_ERROR;
2559  }
2560  qsort((void*)obj_array, length, sizeof(Tcl_Obj*), &StrObjCompare);
2561  return TCL_OK;
2562}
2563
2564static
2565void Tol_HciWriter( const BText & str )
2566{
2567  Tcl_CmdInfo cmd_info;
2568
2569  if (TT_interp && Tcl_GetCommandInfo(TT_interp,"Tol_HciWriter",&cmd_info) ) {
2570    Tcl_DString dstr;
2571    Tcl_Obj * objv[2];
2572   
2573    Tcl_DStringInit(&dstr);
2574    Tcl_IncrRefCount(objv[0]=Tcl_NewStringObj("Tol_HciWriter",-1));
2575    Tcl_ExternalToUtfDString(NULL, ((BText&)str).Buffer(), -1, &dstr);
2576    Tcl_IncrRefCount(objv[1]=Tcl_NewStringObj(Tcl_DStringValue(&dstr), Tcl_DStringLength(&dstr)));
2577    Tcl_DStringFree(&dstr);
2578 
2579    int status = Tcl_EvalObjv(TT_interp, 2, objv, TCL_EVAL_GLOBAL);
2580    if (status != TCL_OK) {
2581      printf("message: %s\n", ((BText&)str).Buffer());
2582      printf("objv[1] : %s\n", Tcl_GetString(objv[1]));
2583      printf("%s\n", TT_interp->result);
2584    }
2585    /* release the objects */
2586    Tcl_DecrRefCount(objv[0]);
2587    Tcl_DecrRefCount(objv[1]);
2588  }
2589}
2590
2591void Tol_InstallHciWriter()
2592{
2593  BOut::PutHciWriter(Tol_HciWriter);
2594  BOut::PutLogHciWriter(Tol_HciWriter);
2595}
2596
2597static
2598void Tol_SerieChart(BList * series, const BText& FileName )
2599{
2600#define CMD_SERIECHART "Tol_SerieChartMethod"
2601#define GRP_NAME "__grptmp_chart__%d"
2602
2603  Tcl_CmdInfo cmd_info;
2604  static int id = 0;
2605
2606  if (TT_interp && Tcl_GetCommandInfo(TT_interp,CMD_SERIECHART,&cmd_info) ) {
2607    Tcl_DString dstr;
2608    Tcl_Obj * objv[3];
2609    Tcl_Obj * obj_result=Tcl_NewObj();
2610    int tcl_result;
2611    char grpname[1024];
2612   
2613    Tcl_IncrRefCount(obj_result);
2614
2615    // first create the group of series
2616    sprintf(grpname, GRP_NAME, ++id);
2617    tcl_result = Tol_CreateSerieGrp(TT_interp, grpname, series, obj_result);
2618    if (tcl_result==TCL_ERROR) {
2619      printf("%s -- error in Tol_CreateSerieGrp: %s\n", CMD_SERIECHART,
2620             Tcl_GetString(obj_result));
2621      Tcl_DecrRefCount(obj_result);
2622      return;
2623    }
2624    // release the obj_result
2625    Tcl_DecrRefCount(obj_result);   
2626    // chart command
2627    Tcl_IncrRefCount(objv[0]=Tcl_NewStringObj(CMD_SERIECHART,-1));
2628    // serie group argument
2629    Tcl_IncrRefCount(objv[1]=Tcl_NewStringObj(grpname,-1));   
2630    // file name argument
2631    Tcl_DStringInit(&dstr);
2632    Tcl_ExternalToUtfDString(NULL, ((BText&)FileName).Buffer(), -1, &dstr);
2633    Tcl_IncrRefCount(objv[2]=Tcl_NewStringObj(Tcl_DStringValue(&dstr), Tcl_DStringLength(&dstr)));
2634    Tcl_DStringFree(&dstr);
2635    int status = Tcl_EvalObjv(TT_interp, 3, objv, TCL_EVAL_GLOBAL);
2636    if (status != TCL_OK) {
2637      printf("%s -- error in Tcl_EvalObjv:\n", CMD_SERIECHART);
2638      printf("%s\n", TT_interp->result);
2639      printf("objv[1] : %s\n", Tcl_GetString(objv[1]));
2640      printf("objv[2] : %s\n", Tcl_GetString(objv[2]));
2641    }
2642    /* release the objects */
2643    for (int i=0; i<3; i++)
2644      Tcl_DecrRefCount(objv[i]);
2645    /* the group of series should be destroyied in the Hook */
2646    /*Tcl_VarEval(TT_interp, "tol::seriegrp destroy ", grpname, NULL);*/
2647  }
2648}
2649
2650int Tol_Tcl_Eval(char * script, const char ** result)
2651{
2652  int status;
2653 
2654  status = Tcl_Eval(TT_interp, script);
2655  *result = Tcl_GetStringResult(TT_interp);
2656  return status==TCL_OK;
2657}
2658
2659Tcl_Obj *TolObj2TclObj( BSyntaxObject *tolObj )
2660{
2661  const char *grammar = tolObj->Grammar( )->Name( ).String( );
2662
2663  if ( !strcmp( grammar, "Text" ) ) {
2664    const BText &value = Text( tolObj );
2665    return Tcl_NewStringObj( value.String( ),-1 );
2666  } else if ( !strcmp( grammar, "Real" ) ) {
2667    const BDat &value = Dat( tolObj );
2668    return Tcl_NewDoubleObj( value.Value( ) );
2669  } else if ( !strcmp( grammar, "Set" ) ) {
2670    // a Tol Set maps to a Tcl list
2671    const BSet &setObj = ( ( BUserSet* )tolObj )->Contens( );
2672    int card = setObj.Card( );
2673    Tcl_Obj **objv = ( Tcl_Obj** )Tcl_Alloc( sizeof( Tcl_Obj* ) * card );
2674    for( int i = 1; i <= card; i++ ) {
2675      objv[ i - 1 ] = TolObj2TclObj( setObj[ i ] );
2676    }
2677    Tcl_Obj *listObj = Tcl_NewListObj( card, objv );
2678    Tcl_Free( ( char* )objv );
2679    return listObj;
2680  } else {
2681    // other types are not treated
2682    return Tcl_NewStringObj( tolObj->Dump( ).String( ),-1 );   
2683  }
2684}
2685
2686int Tol_Tcl_EvalEx( const BSet &Args, const char ** result )
2687{
2688  int status;
2689  Tcl_Obj **objv;
2690  int card = Args.Card( );
2691 
2692  if ( !Args.Card( ) ) {
2693    *result = "";
2694    status = TCL_OK;
2695  } else {
2696    objv = ( Tcl_Obj** )Tcl_Alloc( sizeof( Tcl_Obj* ) * card );
2697    for( int i=1; i<=card; i++ ) {
2698      objv[ i-1 ] = TolObj2TclObj( Args[i] );
2699      Tcl_IncrRefCount( objv[ i - 1 ] );
2700    }
2701    status = Tcl_EvalObjv( TT_interp, card, objv, TCL_EVAL_GLOBAL );
2702    *result = Tcl_GetStringResult( TT_interp );
2703    for( int i = 0; i < card; i++ ) {
2704      Tcl_DecrRefCount(objv[i]);
2705    }
2706  }
2707  return status==TCL_OK;
2708}
2709
2710int Tol_StopEvaluation()
2711{
2712  StopFlagOn();
2713  return TCL_OK;
2714}
2715
2716/*
2717 * Fill in obj_result the format .
2718 *
2719 */
2720
2721int Tol_LCFormat(Tcl_Interp*    interp,
2722                 Tcl_Obj *CONST obj_value,
2723                 Tcl_Obj *      obj_result)
2724{
2725  double value;
2726  char buffer[256];
2727 
2728  /* read the double value from tcl obj */
2729  if (Tcl_GetDoubleFromObj(TT_interp, obj_value, &value)==TCL_ERROR)
2730    {
2731      Tcl_AppendObjToObj(obj_result,Tcl_GetObjResult(interp));
2732      return TCL_ERROR;
2733    }
2734  lc_format(value, buffer);
2735  Tcl_AppendStringsToObj(obj_result, buffer, NULL);
2736  return TCL_OK;
2737}
2738
2739void Tol_InstallMethodsHook()
2740{
2741  InstallSerieChartHook(&Tol_SerieChart);
2742  InstallTclEval(&Tol_Tcl_Eval);
2743  InstallTclEvalEx(&Tol_Tcl_EvalEx);
2744}
Note: See TracBrowser for help on using the repository browser.