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

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

TT_FindOperator : use LeftEvaluate in order to apply ::

git-svn-id: ​https://www.tol-project.org/svn/tolp/trunk@488 be4846ae-f051-483a-831f-b64e7d08527f
  • Property mode set to 100644
File size: 59.7 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_blanguag.h>
34#include <tol/tol_bmatgra.h>
35#include <tol/tol_bvmatgra.h>
36#include <tol/tol_bnameblock.h>
37#include <tol/tol_bspfun.h>
38#include <tol/tol_bcodgra.h>
39#include <tol/tol_bsetgra.h>
40#include <tol/tol_btsrgra.h>
41#include <tol/tol_btxtgra.h>
42#include <tol/tol_bmethodhook.h>
43
44#include <toltclInt.h>
45#include <tt_pool.h>
46
47
48/*
49 * if SyntaxObject has IsFile implemented, uncomment the following
50 * define:
51 */
52
53/* #define ISFILE_IMPLEMENTED */
54
55typedef void (* getmethod)( const BSyntaxObject *, BText & );
56typedef int  (* checkmethod)( const BSyntaxObject * );
57
58static
59int QuickSort( Tcl_Interp * interp, Tcl_Obj * list );
60
61inline
62char * skipWhite(char * pch)
63{
64  while (*pch && isspace(*pch))
65    ++pch;
66  return pch;
67}
68
69static
70BText GetObjectName(const BSyntaxObject * so)
71{
72  return so->HasName() ? so->FullName() : so->LocalName();
73}
74
75static
76void GetName( const BSyntaxObject * so, BText & res )
77{
78  res = so->FullName();
79}
80
81static
82void GetIdentify( const BSyntaxObject * so, BText & res )
83{
84  res = so->Identify();
85}
86
87static
88void GetPath( const BSyntaxObject * so, BText & res )
89{
90  res = so->TolPath();
91}
92
93static
94int
95ExcludeAnything( const BSyntaxObject * so )
96{
97  return so != GraAnything();
98}
99
100static
101int HasNoSource( const BSyntaxObject * so )
102{
103  return !so->Source();
104}
105
106static
107int BList2TclList( Tcl_Interp * interp,
108                   BList * blist, Tcl_Obj * tcl_list,
109                   getmethod m, checkmethod accept = NULL)
110{
111  char * str;
112  Tcl_Obj * name;
113  Tcl_DString dstr;
114  BText tmp;
115
116  while(blist)
117  {
118    BSyntaxObject* so = (BSyntaxObject*)Car(blist);
119    if(!accept || (*accept)(so))
120    {
121      (*m)(so,tmp);
122      str = Tcl_ExternalToUtfDString(NULL,tmp,-1,&dstr);
123      name = Tcl_NewStringObj(str,-1);
124      Tcl_DStringFree(&dstr);
125      if ( Tcl_ListObjAppendElement(interp, tcl_list, name) != TCL_OK ) {
126        Tcl_DecrRefCount(name);
127        return TCL_ERROR;
128      }
129    }
130    blist = Cdr(blist);
131  }
132  return TCL_OK;
133}
134
135/*
136 * Fill in obj_result the result of avaluating in TOL the given
137 * string.
138 *
139 */
140
141/* cdr of console_stack point to first item */
142static BList console_stack;
143// Read only stack
144static BList console_stack_hidden;
145
146static
147void my_concat(BList* head, BList* tail)
148{
149  if (head->Cdr()) {
150    my_concat(head->Cdr(), tail);
151  } else {
152    head->PutCdr(tail);
153  }
154}
155
156int Tol_EvalExpr (Tcl_Obj * obj_expr, int hidden, Tcl_Obj * obj_result)
157{
158  BList * tol_result;
159  Tcl_DString dstr;
160  char * expr;
161 
162  Tcl_DStringInit(&dstr);
163  expr = Tcl_UtfToExternalDString(NULL,Tcl_GetString(obj_expr),-1,&dstr);
164  tol_result = MultyEvaluate(expr);
165  Tcl_DStringFree(&dstr);
166  if(tol_result) {
167    my_concat(hidden?&console_stack_hidden:&console_stack, tol_result);
168  }
169  /*  Tcl_AppendStringsToObj(obj_result,
170      "couldn't evaluate tol expresion \"",
171      Tcl_GetString(obj_expr), "\"", NULL);
172      return TCL_ERROR;*/
173  return TCL_OK;
174}
175
176int Tol_GetStructure( Tcl_Interp * interp, Tcl_Obj * name, Tcl_Obj * obj_result )
177{
178  Tcl_DString dstr;
179  BStruct * structure;
180  BStruct * substruct;
181
182  Tcl_DStringInit( &dstr );
183  Tcl_UtfToExternalDString( NULL, Tcl_GetString(name), -1, &dstr );
184  if ( Tcl_DStringLength( &dstr ) &&
185       (structure = FindStruct(Tcl_DStringValue(&dstr)))) {
186   
187    Tcl_Obj * tmp[2];
188    Tcl_Obj * info[2];
189    Tcl_Obj ** fields;
190    BText btxt;
191    int nfields;
192   
193    nfields = structure->Size();
194    fields = (Tcl_Obj**)Tcl_Alloc( sizeof(Tcl_Obj*) * nfields );
195    for ( int i = 0; i < nfields; i++ ) {
196      BField & field = (*structure)[i];
197      btxt = field.Name();
198      Tcl_DStringFree(&dstr);
199      Tcl_ExternalToUtfDString( NULL, btxt, -1, &dstr );
200      info[0] = Tcl_NewStringObj(Tcl_DStringValue(&dstr), -1);
201      Tcl_DStringFree( &dstr );
202      if ( (substruct = field.Struct()) ) {
203        btxt = substruct->Name();
204        Tcl_ExternalToUtfDString( NULL, btxt, -1, &dstr );
205        tmp[0] = Tcl_NewStringObj( "STRUCT", 6 );
206        tmp[1] = Tcl_NewStringObj( Tcl_DStringValue(&dstr), -1);
207        info[1] = Tcl_NewListObj( 2, tmp );
208      } else if ( field.Grammar() ) {
209        btxt = field.Grammar()->Name();
210        Tcl_ExternalToUtfDString( NULL, btxt, -1, &dstr );
211        info[1] = Tcl_NewStringObj(Tcl_DStringValue(&dstr), -1);
212      }
213      fields[i] = Tcl_NewListObj(2,info);
214    }
215    Tcl_SetListObj( obj_result, nfields, fields );
216    Tcl_Free( (char*)fields );
217  }
218  return TCL_OK;
219}
220
221BSet* ContainerGetSet(const BSyntaxObject *container)
222{
223  if (container) {
224    if (container->Grammar()==GraSet())
225      return &(((BUserSet*)container)->Contens());
226    else if (container->Grammar()==GraNameBlock())
227      return &(((BUserNameBlock*)container)->Contens().Set());
228  }
229  return NULL;
230}
231 
232/*
233 * Return the path of a set if it is a file, trigger an error in other case
234 *
235 */
236
237int Tol_GetSetPath( Tcl_Interp * interp, Tcl_Obj * name, Tcl_Obj * obj_result )
238{
239  Tcl_DString uniBuffer;
240  const BSyntaxObject * syn;
241
242 /* if name contains spaces the we should try it first as a string */
243  Tcl_DStringInit(&uniBuffer);
244  Tcl_UtfToExternalDString(NULL,Tcl_GetString(name),-1,&uniBuffer);
245  BText fname(Tcl_DStringValue(&uniBuffer));
246  syn = (BSyntaxObject*)BSetFromFile::FindCompiled(fname);
247  Tcl_DStringFree(&uniBuffer);
248  if (!syn) {
249    syn = Tol_ResolveObject(interp, name, obj_result);
250  }
251  if ( !syn )
252    return TCL_ERROR;
253  BSet *ptrSet = ContainerGetSet(syn);
254  if ( ptrSet->SubType() >= BSet::MODFile && ptrSet->SubType() <= BSet::BMIFile ) {
255    Tcl_DString dstr;
256    BText path( syn->TolPath() );
257
258    Tcl_DStringInit( &dstr );
259    Tcl_ExternalToUtfDString(NULL,path,-1,&dstr);
260    Tcl_SetStringObj( obj_result, Tcl_DStringValue(&dstr), -1 );
261    return TCL_OK;
262  } else {
263    Tcl_AppendStringsToObj( obj_result, Tcl_GetString(name),
264                            " is not a valid file object", NULL );
265    return TCL_ERROR;
266  }
267}
268
269/*
270 * Fill in obj_result the content of the given tol object's names. The
271 * object are searched in the console's stack.
272 *
273 * Return:
274 *
275 *   {GRAMMAR NAME CONTENT PATH DESCRIPTION ISFILE [Has SubSet? SUBTYPE STRUCTURE]}
276 */
277
278int Tol_ListStack(Tcl_Interp * interp,int objc,Tcl_Obj *CONST objv[],
279                  Tcl_Obj * obj_result)
280{
281  BSyntaxObject * so;
282  BText btxt;
283  Tcl_DString dstr;
284  BList * tol_item;
285  Tcl_Obj * robjv[9];
286  int robjc;
287  Tcl_Obj * tcl_item;
288  int tcl_result;
289  BSet * ptrSet = 0;
290  int tmpCard;
291  int j;
292 
293  Tcl_DStringInit(&dstr);
294 
295  tol_item = console_stack.Cdr();
296  while (tol_item) {
297    so = (BSyntaxObject*)Car(tol_item);
298   
299    /* GRAMMAR NAME */
300    btxt = so->Grammar()->Name();
301    Tcl_ExternalToUtfDString(NULL,btxt,-1,&dstr);
302    robjv[0] = Tcl_NewStringObj(Tcl_DStringValue(&dstr),-1);
303    Tcl_DStringFree(&dstr);
304   
305    /* OBJECT NAME */
306//  btxt = so->Identify();
307    GetName( so, btxt );
308    Tcl_ExternalToUtfDString(NULL,btxt,-1,&dstr);
309    robjv[1] = Tcl_NewStringObj(Tcl_DStringValue(&dstr),-1);
310    Tcl_DStringFree(&dstr);
311   
312    /* OBJECT CONTENT */
313    btxt = so->Info();
314    Tcl_ExternalToUtfDString(NULL,btxt,-1,&dstr);
315    robjv[2] = Tcl_NewStringObj(Tcl_DStringValue(&dstr),-1);
316    Tcl_DStringFree(&dstr);
317   
318    /* OBJECT PATH */
319    btxt = so->SourcePath();
320    Tcl_ExternalToUtfDString(NULL,btxt,-1,&dstr);
321    robjv[3] = Tcl_NewStringObj(Tcl_DStringValue(&dstr),-1);
322    Tcl_DStringFree(&dstr);
323   
324    /* OBJECT DESCRIPTION */
325    btxt = so->Description();
326    Tcl_ExternalToUtfDString(NULL,btxt,-1,&dstr);
327    robjv[4] = Tcl_NewStringObj(Tcl_DStringValue(&dstr),-1);
328    Tcl_DStringFree(&dstr);
329   
330    /* IS THE OBJECT A FILE? */
331    robjv[5] = Tcl_NewIntObj(so->IsFile());
332////    if ( so->Grammar()==GraSet() ) {
333    if ( so->Grammar()==GraSet() || so->Grammar()==GraNameBlock()) {
334      /* HAS SUBSET */
335////      ptrSet = &(((BUserSet*)so)->Contens());
336      ptrSet = ContainerGetSet(so);
337      tmpCard = ptrSet->Card();
338      for (j=1; j<=tmpCard; ++j )
339        if ( (*ptrSet)[j]->Grammar()==GraSet() )
340          break;
341      robjv[6] = Tcl_NewIntObj(j<=tmpCard);
342       
343      /* SUBTYPE INFO */
344      robjv[7] = Tcl_NewIntObj( ptrSet->SubType() );
345       
346      /* STRUCT INFO */
347      if ( ptrSet->Struct() ) {
348        btxt = ptrSet->Struct()->Name();
349        Tcl_ExternalToUtfDString(NULL,btxt,-1,&dstr);
350        robjv[8] = Tcl_NewStringObj( Tcl_DStringValue(&dstr), -1 );
351        Tcl_DStringFree( &dstr );
352      } else
353        robjv[8] = Tcl_NewStringObj( NULL, 0 );
354      robjc = 9;
355    } else
356      robjc = 6;
357   
358    /* build the tcl item as a list */
359    tcl_item = Tcl_NewListObj(robjc,robjv);
360   
361    /* append to the end of the result */
362    tcl_result = Tcl_ListObjAppendElement(interp,obj_result,tcl_item);
363    if (tcl_result != TCL_OK) {
364      Tcl_SetStringObj(obj_result,"",-1);
365      Tcl_AppendObjToObj(obj_result,Tcl_GetObjResult(interp));
366      return TCL_ERROR;
367    }
368    tol_item = Cdr(tol_item);
369  }
370  return TCL_OK;
371}
372
373struct tcl_info_t
374{
375  Tcl_Interp *interp;
376  int objc;
377  Tcl_Obj* CONST* objv;
378  Tcl_DString &dstr;
379};
380
381/*
382 * Tol_ReleaseStack --
383 *
384 * Recursive version in order to release stack in reverse order
385 *
386 * Preconditions:
387 *
388 *   P != NULL
389 */
390static
391int Tol_ReleaseStack(tcl_info_t &info, BList *P)
392{
393  int result;
394 
395  assert(P != NULL);
396
397  if (P->Cdr()) {
398    /* keep on looking for rest of items */
399    result = Tol_ReleaseStack(info, P->Cdr());
400    /* process this item */
401    BList *current = P->Cdr();
402    BSyntaxObject * so;
403    int i;
404    so = (BSyntaxObject*)(current->Car());
405    if (info.objc) {
406      const char* name = so->Name().String();
407      for (i = 0; i<info.objc; ++i) {
408        Tcl_UtfToExternalDString(NULL,Tcl_GetString(info.objv[i]),-1,
409                                 &info.dstr);
410        if (!strcmp(Tcl_DStringValue(&info.dstr), name)) {
411          Tcl_DStringFree(&info.dstr);
412          break;
413        }
414        Tcl_DStringFree(&info.dstr);
415      }
416    } else {
417      /* mark current as being found */
418      i = -1;
419    }
420    if (i<info.objc) {
421      BList *next = current->Cdr();
422      /* delete will DecNRefs to the Car */
423      delete current;
424      /* now try to release the BSyntaxObject */
425      DESTROY(so);
426      /* chain the list */
427      P->PutCdr(next);
428    }
429  } else {
430    /* EOR */
431    result = TCL_OK;
432  }
433  return result;
434}
435
436int Tol_ReleaseStack(Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[],
437                     Tcl_Obj * obj_result)
438{
439  Tcl_DString dstr;
440  tcl_info_t tcl_info = {interp, objc, objv, dstr};
441  Tcl_DStringInit(&dstr);
442
443  return Tol_ReleaseStack(tcl_info, &console_stack);
444}
445
446/*!
447 * Tol_GetConsoleObject --
448 *
449 *     Returns the object with given index in the console object list.
450 */
451BSyntaxObject * Tol_GetConsoleObject(int index )
452{
453  BList * current = console_stack.Cdr();
454  int i = 1;
455  while (current) {
456    if (i==index) break;
457    current = Cdr(current);
458    ++i;
459  }
460  return current ? (BSyntaxObject*)(current->Car()) : NULL;
461}
462
463
464/*
465 * return the container (File, Set or NameBlock) with name obj_name,
466 * in case of error return NULL and leave a description in
467 * obj_result.
468 *
469 */
470const BSyntaxObject * Tol_FindGlobalContainer(const char* Type,
471                                              const char* obj_name,
472                                              Tcl_Obj*    obj_result)
473{
474  BGrammar *gra;
475  BSyntaxObject* var;
476  Tcl_DString uniBuffer;
477
478  if (!strcmp(Type, "Set"))
479    gra = GraSet();
480  else if (!strcmp(Type, "NameBlock"))
481    gra = GraNameBlock();
482  else if (!strcmp(Type, "File"))
483    gra = NULL;
484  else {
485    Tcl_AppendStringsToObj(obj_result,"type '",
486                           Type,
487                           "' is not a container grammar", NULL );
488    return NULL;
489  }
490  Tcl_DStringInit(&uniBuffer);
491  Tcl_UtfToExternalDString(NULL,obj_name,-1,&uniBuffer);
492  if (!gra) {
493    /* should look in Files */
494    BText fname(Tcl_DStringValue(&uniBuffer));
495    if (!(var=(BSyntaxObject*)BSetFromFile::FindCompiled(fname))) {
496      Tcl_AppendStringsToObj(obj_result,"file \"",
497                             obj_name,
498                             "\" is not included", NULL );
499    }
500  } else if (!(var=gra->FINDVARIABLE(Tcl_DStringValue(&uniBuffer)))) {
501      Tcl_AppendStringsToObj(obj_result,"\"",
502                             obj_name,
503                             "\" isn't a ", Type, " variable", NULL );
504  }
505  Tcl_DStringFree(&uniBuffer);
506  return var;
507}
508
509/*
510 * given a tol set, returns its child corresponding to the set of
511 * indexes indexes of size n.  In case of error return NULL and leave
512 * a description in obj_result.
513 *
514 */
515
516const BSyntaxObject * Tol_FindChild(Tcl_Interp    *interp,
517                                    const BSyntaxObject *syn_obj,
518                                    Tcl_Obj       **indexes, int n,
519                                    Tcl_Obj       *obj_result)
520{
521  int tcl_code;
522  Tcl_DString dstr;
523  BSet *container;
524  int idx, card;
525  int i;
526
527  for (i=0; i<n; ++i) {
528    if (!(container = ContainerGetSet(syn_obj))) {
529      BText info(syn_obj->Info());
530      Tcl_DStringInit(&dstr);
531      Tcl_ExternalToUtfDString(NULL,info,-1,&dstr);
532      Tcl_AppendStringsToObj(obj_result,"object \"",
533                             Tcl_DStringValue(&dstr),
534                             "\" is not a container",
535                             NULL);
536      Tcl_DStringFree(&dstr);
537      break;
538    }
539    /* get the current object index */
540    tcl_code = Tcl_GetIntFromObj(interp,indexes[i],&idx);
541    if (tcl_code != TCL_OK) {
542      Tcl_AppendObjToObj(obj_result,Tcl_GetObjResult(interp));
543      break;
544    }
545    card = container->Card();
546    if (idx<1 || idx>card) {
547      Tcl_AppendStringsToObj(obj_result,
548                             "index '",
549                             Tcl_GetString(indexes[i]),
550                             "' out of range",
551                             NULL);
552      break;
553    }
554    /* take the next object in the list */
555    syn_obj = (*container)[idx];
556  }
557  return i == n ? syn_obj : NULL;
558}
559
560/*!
561 *  Tol_ResolveObject --
562 *
563 *     Resolve a SyntaxObject given a toltcl object reference. A
564 *     reference is {TYPE ?container? i1 i2 ... in} or a global
565 *     container's name of type File|Set|NameBlock|Console. When TYPE
566 *     is Console then container is not given. The grammar of the
567 *     object found is matched to the given argument grammar. If the
568 *     return value is NULL an error message is left in interp.
569 */
570
571const BSyntaxObject * Tol_ResolveObject(Tcl_Interp *interp,
572                                        Tcl_Obj    *obj_ref,
573                                        Tcl_Obj    *obj_result)
574{
575  Tcl_Obj ** items;
576  int n;
577  int tcl_code;
578  char * type;
579
580  /* look for subitem given in obj_ref */
581  tcl_code = Tcl_ListObjGetElements(interp, obj_ref, &n, &items);
582  if (tcl_code != TCL_OK) {
583    Tcl_AppendObjToObj(obj_result,Tcl_GetObjResult(interp));
584    return NULL;
585  }
586
587  // this Tcl_Obj is to leave error messages
588  const BSyntaxObject * syn = NULL;
589
590  if (n >= 2) {
591    type = Tcl_GetString(items[0]);
592    if (!strcmp(type,"Console") || !strcmp(type,"File") ||
593        !strcmp(type,"Set") || !strcmp(type,"NameBlock") ) {
594      if (!strcmp(type,"Console")) {
595        // is a reference in the console, items[1] is the first index in
596        // the path, following indexes are indexes withing containers.
597        int i1;
598        if ((tcl_code = Tcl_GetIntFromObj(interp,items[1],&i1)!=TCL_OK)) {
599          Tcl_AppendObjToObj(obj_result,Tcl_GetObjResult(interp));
600          return NULL;
601        }
602        if (!(syn=Tol_GetConsoleObject(i1))) {
603          Tcl_AppendStringsToObj(obj_result, "index ",
604                                 Tcl_GetString(items[1]),
605                                 " not found in console", NULL);
606          return NULL;
607        }
608      } else {
609      /* should be File, Set or NameBlock, it is a hierarchical container */
610        if (!(syn=Tol_FindGlobalContainer(Tcl_GetString(items[0]),
611                                          Tcl_GetString(items[1]),
612                                          obj_result))) {
613          return NULL;
614        }
615      }
616      assert(syn);
617      if (n>2) {
618        // there are more indexes & syn should be a Container
619        if (!(syn=Tol_FindChild(interp,
620                                syn, items+2, n-2, obj_result))) {
621          return NULL;
622        }
623      }
624    } else {
625      if (n==2) {
626        // look global var in grammar
627        BGrammar * gra;
628        gra = BGrammar::FindByName(type);
629        if (!gra) {
630          Tcl_AppendStringsToObj(obj_result, "\"",
631                                                   type,
632                                                   "\" isn't a grammar", NULL);
633          return NULL;
634        }
635        Tcl_DString dstr;
636        Tcl_DStringInit(&dstr);
637        Tcl_UtfToExternalDString(NULL,Tcl_GetString(items[1]),-1,&dstr);
638        if (!(syn = gra->FINDVARIABLE(Tcl_DStringValue(&dstr))))
639          Tcl_AppendStringsToObj(obj_result, "variable '",
640                                 obj_ref, "' not found in grammar '",
641                                 gra->Name().String(), "'", NULL);
642        Tcl_DStringFree(&dstr);
643        /* found and matched */
644        return syn;
645      }
646    }
647  } else {
648      Tcl_AppendStringsToObj(obj_result,
649                             "incorrect object reference in ResolveObject",
650                             NULL);
651  }
652/*  if (grammar && syn && syn->Grammar()!=grammar) {
653    Tcl_AppendStringsToObj(obj_result, "grammar for object '",
654                           Tcl_GetString(obj_ref),
655                           "' does not match grammar '",
656                           grammar->Name().String(), "'", NULL);
657    syn = NULL;
658  }
659*/
660  return syn;
661}
662
663int Tol_FindSOInSet(BSet * ptrSet, const BSyntaxObject * syn,
664                    ToltclPool & indexes)
665{
666  int j;
667  const BSyntaxObject * so;
668 
669  for (j = 1; j <= ptrSet->Card(); j++) {
670    so = (*ptrSet)[j];
671    BSet *ptrSet;
672    if (so == syn || ((ptrSet=ContainerGetSet(so)) &&
673                      Tol_FindSOInSet(ptrSet,
674                                      syn, indexes))) {
675      /* found!!! */
676      indexes.AppendObject((void*)j);     
677      return 1;
678    }
679  }
680
681  return 0;
682}
683 
684/*
685 *  Puts in obj_result the global reference of the given
686 *  syntaxobject. The syntaxobject could be given as set member or as
687 *  global variable. In case of error leave in obj_result the message.
688 *  Returns TCL_OK if succesfull or TCL_ERROR in case of error.
689 */
690
691int Tol_GetReference(Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[],
692                     Tcl_Obj * obj_result)
693{
694  Tcl_Obj ** items;
695  int n;
696  int tcl_code;
697  const BSyntaxObject * source, * syn;
698  BSet * ptrSet;
699  ToltclPool indexes;
700  Tcl_DString dstr;
701  int j;
702  char * graname, * objname;
703
704  assert(!Tcl_IsShared(obj_result));
705  tcl_code = Tcl_ListObjGetElements(interp,objv[0],&n,&items);
706  assert(tcl_code == TCL_OK);
707  if (n<2) {
708    Tcl_AppendStringsToObj(obj_result,
709                           "wrong # args: should be 'tol::info",
710                           " reference {grammar|container objname ?indexes?}'",
711                           NULL);
712    return TCL_ERROR;   
713  }
714  if (n==2 && strcmp(Tcl_GetString(items[0]),"Console")) {
715  // global access
716    BGrammar * gra;
717    graname = Tcl_GetString(items[0]);
718    gra = BGrammar::FindByName(graname);
719    if (!gra) {
720      Tcl_AppendStringsToObj( obj_result, "\"",
721                              graname,
722                              "\" isn't a grammar", NULL);
723      return TCL_ERROR;
724    }
725    objname = Tcl_GetString(items[1]);
726    Tcl_UtfToExternalDString(NULL,objname,-1,&dstr);
727    syn = gra->FINDVARIABLE(Tcl_DStringValue(&dstr));
728    Tcl_DStringFree(&dstr);
729    if (!syn) {
730      Tcl_AppendStringsToObj(obj_result, "\"",
731                             Tcl_GetString(items[1]),
732                             "\" isn't a variable in grammar ",
733                             graname, NULL);
734      return TCL_ERROR;
735    }
736    source = syn->Source();
737    if (!source) {
738      /* is a global variable not defined inside a file */
739      items = (Tcl_Obj**)Tcl_Alloc(sizeof(Tcl_Obj*) * 2);
740      Tcl_ExternalToUtfDString(NULL, graname, -1, &dstr);
741      items[0] = Tcl_NewStringObj(Tcl_DStringValue(&dstr), -1);
742      Tcl_DStringFree(&dstr);
743      Tcl_ExternalToUtfDString(NULL, objname, -1, &dstr);
744      items[1] = Tcl_NewStringObj(Tcl_DStringValue(&dstr), -1);
745      Tcl_DStringFree(&dstr);
746      Tcl_SetListObj(obj_result, 2, items);
747      Tcl_Free((char*)items);
748      return TCL_OK;
749    }
750  } else {
751    // member access
752    if (!(syn=Tol_ResolveObject(interp,objv[0],obj_result))) {
753      return TCL_ERROR;
754    }
755    /* here we have a valid reference */
756    tcl_code = Tcl_ListObjGetElements(interp,objv[0],&n,&items);
757    assert(tcl_code == TCL_OK);
758    if (!strcmp(Tcl_GetString(items[0]),"File") ||
759        !strcmp(Tcl_GetString(items[0]),"Console")) {
760      /* here we have in objv[0] the answer */
761      Tcl_SetListObj(obj_result, n, items);
762      return TCL_OK;     
763    }
764    source = syn->Source();
765    if (!source) {
766      /* here we have in objv[0] the answer too */
767      Tcl_SetListObj(obj_result, n, items);
768      return TCL_OK;
769    }
770  }
771  /* at this point variable has to be defined inside a file */
772  assert(source);
773  ptrSet = &(((BUserSet*)source)->Contens());
774  if (Tol_FindSOInSet(ptrSet, syn, indexes)) {
775    items = (Tcl_Obj**)Tcl_Alloc(sizeof(Tcl_Obj*) * (indexes.GetSize()+2));
776    Tcl_ExternalToUtfDString(NULL, "File", -1, &dstr);
777    items[0] = Tcl_NewStringObj(Tcl_DStringValue(&dstr), -1);
778    Tcl_DStringFree(&dstr);
779    Tcl_ExternalToUtfDString(NULL, source->Name(), -1, &dstr);
780    items[1] = Tcl_NewStringObj(Tcl_DStringValue(&dstr), -1);
781    Tcl_DStringFree(&dstr);
782    int last = indexes.GetLast();
783    for(j = last; j >= 0; j--)
784      items[last+2-j] = Tcl_NewIntObj(long(*indexes._GetObject(j)));
785    Tcl_SetListObj(obj_result, indexes.GetSize()+2, items);
786    Tcl_Free((char*)items);
787    return TCL_OK;
788  } else {
789    /* this should not happend because syn should be inside syn->source */
790    Tcl_AppendStringsToObj(obj_result,
791                             "internal error: syn not found in syn->Source()",
792                             NULL);
793    return TCL_ERROR;
794  }
795}
796
797
798/*
799 * Iterate over a first level's children of a given set.  The set
800 * could be a container Set, File or NameBlock if the index list is
801 * empty or container[i1][i2]...[ik] for the given indexes
802 * {i1,i2,...,ik}
803 *
804 */
805
806int Tol_IterChildren(Tcl_Interp * interp,
807                     int objc,
808                     Tcl_Obj *CONST objv[],
809                     Tcl_Obj * obj_result)
810{
811#define ARG_SCRIPT    0
812#define ARG_GRAMMAR   ARG_SCRIPT+1
813#define ARG_NAME      ARG_GRAMMAR+1
814#define ARG_CONTENT   ARG_NAME+1
815#define ARG_PATH      ARG_CONTENT+1
816#define ARG_DESC      ARG_PATH+1
817#define ARG_INDEXES   ARG_DESC+1
818#define ARG_ISFILE    ARG_INDEXES+1
819#define ARG_HASSUBSET ARG_ISFILE+1
820#define ARG_SUBTYPE   ARG_HASSUBSET+1
821#define ARG_STRUCT    ARG_SUBTYPE+1
822#define NUM_ARGS      ARG_STRUCT+1
823
824  const BSyntaxObject* container;
825  Tcl_DString dstr;
826  Tcl_Obj * ArgIndexes;
827  int tcl_code, cont_loop;
828  int i, card ;
829  int n, index_length;
830  Tcl_Obj ** items;
831
832  int length = 0;
833 
834  if (Tcl_ListObjLength(interp,objv[0],&length)!=TCL_OK) {
835    Tcl_AppendObjToObj(obj_result,Tcl_GetObjResult(interp));
836    return TCL_ERROR;
837  }
838  if (length<2) {
839    Tcl_AppendStringsToObj(obj_result,
840                           "invalid object reference '",
841                           Tcl_GetString(objv[0]),
842                           "must be {TYPE ?name? i1 i2 ... ik}",
843                           NULL);
844    return TCL_ERROR;
845  }
846
847  if (!(container=Tol_ResolveObject(interp, objv[0], obj_result))) {
848    return TCL_ERROR;
849  }
850  BSet *set = ContainerGetSet(container);
851  if (!set) {
852    Tcl_AppendStringsToObj(obj_result,
853                           "object '",
854                           Tcl_GetString(objv[0]),
855                           "' is not a valid container ",
856                           NULL);
857      return TCL_ERROR;
858  }
859 
860  card = set->Card();
861 
862  int datac;
863  Tcl_Obj * datav[NUM_ARGS];
864  // is ok to ask for a list
865  Tcl_ListObjGetElements(interp,objv[0],&n,&items);
866 
867  if (strcmp(Tcl_GetString(items[0]),"Console")) {
868    if (n>2)
869      ArgIndexes = Tcl_NewListObj(n-2,items+2);
870    else
871      ArgIndexes = Tcl_NewListObj(0,NULL);
872  } else {
873    if (n>1)
874      ArgIndexes = Tcl_NewListObj(n-1,items+1);
875    else
876      ArgIndexes = Tcl_NewListObj(0,NULL);
877  }
878
879  datav[ARG_SCRIPT] = objv[1];
880 
881  datav[ARG_GRAMMAR] = Tcl_NewObj();
882  datav[ARG_NAME]    = Tcl_NewObj();
883  datav[ARG_CONTENT] = Tcl_NewObj();
884  datav[ARG_PATH]    = Tcl_NewObj();
885  datav[ARG_DESC]    = Tcl_NewObj();
886  Tcl_Obj * last_index = Tcl_NewIntObj(0);
887  Tcl_ListObjAppendElement(NULL,ArgIndexes,last_index);
888  datav[ARG_INDEXES] = ArgIndexes;
889  Tcl_ListObjLength(NULL,datav[ARG_INDEXES],&index_length);
890  datav[ARG_ISFILE] = Tcl_NewObj();
891  datav[ARG_HASSUBSET] = Tcl_NewObj();
892  datav[ARG_SUBTYPE] = Tcl_NewObj();
893  datav[ARG_STRUCT] = Tcl_NewObj();
894  for (i=ARG_GRAMMAR; i<NUM_ARGS; ++i)
895    Tcl_IncrRefCount(datav[i]);
896 
897  BSyntaxObject *syn_i;
898  BSet          *set_i; /* just in case syn_i be a container */
899  /* now iter over its children */
900 
901  Tcl_DStringInit(&dstr);
902  BText btxt;
903 
904 
905  for (i=1; i<=card; ++i) {
906    syn_i = (*set)[i];
907   
908    /* read the grammar */
909   
910    btxt = syn_i->Grammar()->Name();
911    Tcl_ExternalToUtfDString(NULL,btxt,-1,&dstr);
912    if (Tcl_IsShared(datav[ARG_GRAMMAR])) {
913      Tcl_DecrRefCount(datav[ARG_GRAMMAR]);
914      datav[ARG_GRAMMAR] = Tcl_NewStringObj(Tcl_DStringValue(&dstr),-1);
915      Tcl_IncrRefCount(datav[ARG_GRAMMAR]);
916    } else
917      Tcl_SetStringObj(datav[ARG_GRAMMAR], Tcl_DStringValue(&dstr),-1);
918    Tcl_DStringFree(&dstr);
919   
920    /* read the name */
921   
922    //btxt = syn_i->Identify();
923    GetName( syn_i, btxt );
924    Tcl_ExternalToUtfDString(NULL,btxt,-1,&dstr);
925    if (Tcl_IsShared(datav[ARG_NAME])) {
926      Tcl_DecrRefCount(datav[ARG_NAME]);
927      datav[ARG_NAME] = Tcl_NewStringObj(Tcl_DStringValue(&dstr),-1);
928      Tcl_IncrRefCount(datav[ARG_NAME]);
929    } else
930      Tcl_SetStringObj(datav[ARG_NAME], Tcl_DStringValue(&dstr),-1);
931    Tcl_DStringFree(&dstr);
932   
933    /* read the content */
934   
935    btxt = syn_i->Info();
936    Tcl_ExternalToUtfDString(NULL,btxt,-1,&dstr);
937    if (Tcl_IsShared(datav[ARG_CONTENT])) {
938      Tcl_DecrRefCount(datav[ARG_CONTENT]);
939      datav[ARG_CONTENT] = Tcl_NewStringObj(Tcl_DStringValue(&dstr),-1);
940      Tcl_IncrRefCount(datav[ARG_CONTENT]);
941    } else
942      Tcl_SetStringObj(datav[ARG_CONTENT],Tcl_DStringValue(&dstr),-1);
943    Tcl_DStringFree(&dstr);
944   
945    /* read the path */
946   
947    btxt = syn_i->SourcePath();
948    Tcl_ExternalToUtfDString(NULL,btxt,-1,&dstr);
949    if (Tcl_IsShared(datav[ARG_PATH])) {
950      Tcl_DecrRefCount(datav[ARG_PATH]);
951      datav[ARG_PATH] = Tcl_NewStringObj(Tcl_DStringValue(&dstr),-1);
952      Tcl_IncrRefCount(datav[ARG_PATH]);
953    } else
954      Tcl_SetStringObj(datav[ARG_PATH],Tcl_DStringValue(&dstr),-1);
955    Tcl_DStringFree(&dstr);
956   
957    /* read the description */
958   
959    btxt = syn_i->Description();
960    Tcl_ExternalToUtfDString(NULL,btxt,-1,&dstr);
961    if (Tcl_IsShared(datav[ARG_DESC])) {
962      Tcl_DecrRefCount(datav[ARG_DESC]);
963      datav[ARG_DESC] = Tcl_NewStringObj(Tcl_DStringValue(&dstr),-1);
964      Tcl_IncrRefCount(datav[ARG_DESC]);
965    } else
966      Tcl_SetStringObj(datav[ARG_DESC],Tcl_DStringValue(&dstr),-1);
967    Tcl_DStringFree(&dstr);
968   
969    if ((set_i=ContainerGetSet(syn_i))) {
970      /* update last index */
971      if (Tcl_IsShared(last_index)) {
972        last_index = Tcl_NewIntObj(i);
973        Tcl_ListObjReplace(NULL, datav[ARG_INDEXES], index_length-1,
974                           1, 1, &last_index);
975      }
976      /*
977      if (Tcl_IsShared(datav[ARG_INDEXES])) {
978        Tcl_DecrRefCount(datav[ARG_INDEXES]);
979        datav[ARG_INDEXES] = Tcl_DuplicateObj(datav[ARG_INDEXES]);
980        Tcl_IncrRefCount(datav[ARG_INDEXES]);
981        Tcl_ListObjLength(NULL,datav[ARG_INDEXES],&n);
982        Tcl_ListObjIndex(NULL,datav[ARG_INDEXES],n-1,&last_index);
983      }
984      */
985      /* set the last value index */
986      Tcl_SetIntObj(last_index,i);
987      /* to refresh the string */
988      Tcl_InvalidateStringRep(datav[ARG_INDEXES]);
989      if (Tcl_IsShared(datav[ARG_ISFILE])) {
990        Tcl_DecrRefCount(datav[ARG_ISFILE]);
991#ifdef ISFILE_IMPLEMENTED
992        datav[ARG_ISFILE] = Tcl_NewIntObj(syn_i->IsFile());
993#else
994        datav[ARG_ISFILE] = Tcl_NewIntObj(0);
995#endif
996        Tcl_IncrRefCount(datav[ARG_ISFILE]);
997      } else
998#ifdef ISFILE_IMPLEMENTED
999        Tcl_SetIntObj(datav[ARG_ISFILE],syn_i->IsFile());
1000#else
1001      Tcl_SetIntObj(datav[ARG_ISFILE],0);
1002#endif
1003      /* verify if has subset */
1004      int tmpCard = set_i->Card();
1005      int j;
1006      for (j=1; j<=tmpCard; ++j )
1007        if (ContainerGetSet((*set_i)[j]))
1008          break;
1009      if (Tcl_IsShared(datav[ARG_HASSUBSET])) {
1010        Tcl_DecrRefCount(datav[ARG_HASSUBSET]);
1011        datav[ARG_HASSUBSET] = Tcl_NewIntObj(j<=tmpCard);
1012        Tcl_IncrRefCount(datav[ARG_HASSUBSET]);
1013      } else
1014        Tcl_SetIntObj(datav[ARG_HASSUBSET],j<=tmpCard);
1015       
1016      /* subtype info */
1017       
1018      if (Tcl_IsShared(datav[ARG_SUBTYPE])) {
1019        Tcl_DecrRefCount(datav[ARG_SUBTYPE]);
1020        datav[ARG_SUBTYPE] = Tcl_NewIntObj(set_i->SubType());
1021        Tcl_IncrRefCount(datav[ARG_SUBTYPE]);
1022      } else
1023        Tcl_SetIntObj(datav[ARG_SUBTYPE],set_i->SubType());
1024       
1025      /* STRUCT INFO */
1026      if ( set_i->Struct() ) {
1027        btxt = set_i->Struct()->Name();
1028        Tcl_ExternalToUtfDString(NULL,btxt,-1,&dstr);
1029      }
1030      if (Tcl_IsShared(datav[ARG_STRUCT])) {
1031        Tcl_DecrRefCount(datav[ARG_STRUCT]);
1032        datav[ARG_STRUCT] = Tcl_NewStringObj(Tcl_DStringValue(&dstr),-1);
1033        Tcl_IncrRefCount(datav[ARG_STRUCT]);
1034      } else
1035        Tcl_SetStringObj(datav[ARG_STRUCT],Tcl_DStringValue(&dstr),-1);
1036      Tcl_DStringFree(&dstr);
1037      datac = NUM_ARGS;
1038    } else
1039      datac = ARG_INDEXES;
1040    tcl_code = Tcl_EvalObjv(interp,datac,datav,TCL_EVAL_GLOBAL);
1041    if (tcl_code != TCL_OK) {
1042      /* liberar los objetos tcl */
1043      for (i=ARG_GRAMMAR; i<NUM_ARGS; ++i)
1044        Tcl_DecrRefCount(datav[i]);
1045      Tcl_AppendObjToObj(obj_result,Tcl_GetObjResult(interp));
1046      return tcl_code;
1047    }
1048    /* check if break loop */
1049    cont_loop = 1;
1050    tcl_code = Tcl_GetIntFromObj(interp,Tcl_GetObjResult(interp),&cont_loop);
1051    if (tcl_code == TCL_OK && !cont_loop)
1052      break;
1053  }
1054 
1055  /* liberar los objetos tcl */
1056  for (i=ARG_GRAMMAR; i<NUM_ARGS; ++i)
1057    Tcl_DecrRefCount(datav[i]);
1058  return TCL_OK;
1059}
1060
1061/*
1062 * Fill in obj_result the content of the matrix variable.
1063 *
1064 */
1065
1066int Tol_GetMatrixContent(Tcl_Interp * interp,
1067                         Tcl_Obj * obj_name,
1068                         Tcl_Obj * obj_result)
1069{
1070  //BGrammar * gra = NULL;
1071  const BSyntaxObject *tol_obj = NULL;
1072   
1073  if (!(tol_obj=Tol_ResolveObject(interp, obj_name, obj_result))) {
1074    return TCL_ERROR;
1075  }
1076
1077  BMatrix<double> vmat;
1078  BMatrix<double> &theMat = vmat;
1079
1080  if (tol_obj->Grammar()==GraVMatrix()) {
1081    BVMat &V = VMat((BSyntaxObject *)tol_obj);
1082    V.GetDMat(vmat);
1083  } else if (tol_obj->Grammar()==GraMatrix()) {
1084    theMat = ((DMat&)Mat((BSyntaxObject *)tol_obj));
1085  } else { 
1086    Tcl_AppendStringsToObj( obj_result, Tcl_GetString(obj_name),
1087                            " is not a valid Matrix|VMatrix object", NULL );   
1088    return TCL_ERROR;
1089  }
1090   
1091#define IT_NAME 0
1092#define IT_ROWS 1
1093#define IT_COLS 2
1094#define IT_DATA 3
1095#define IT_SIZE 4
1096     
1097  Tcl_Obj * items[4];
1098  Tcl_Obj ** subitems;
1099  int r, Rows, c, Cols;
1100  BDat & dat = BDat::Unknown();
1101 
1102  //BMatrix<BDat> & mat = (BMatrix<BDat>&)(((BUserMat*)tol_obj)->Contens());
1103 
1104  //items[IT_NAME] = Tcl_NewStringObj(tol_obj->Identify(),-1);
1105  BText tmp;
1106  GetName( tol_obj, tmp );
1107  items[IT_NAME] = Tcl_NewStringObj(tmp.Buffer(),-1);
1108  Rows = theMat.Rows();
1109  Cols = theMat.Columns();
1110  items[IT_ROWS] = Tcl_NewIntObj(Rows);
1111  items[IT_COLS] = Tcl_NewIntObj(Cols);
1112  subitems = (Tcl_Obj**)Tcl_Alloc( sizeof(Tcl_Obj*)*Rows*Cols );
1113  for ( r = 0; r < Rows; ++r )
1114    for ( c = 0; c < Cols; ++c ) {
1115      dat = theMat(r,c);
1116      if (dat.IsKnown())
1117        subitems[r*Cols+c] = Tcl_NewDoubleObj(dat.Value());
1118      else
1119        subitems[r*Cols+c] = Tcl_NewStringObj("?",-1);
1120    }
1121  items[IT_DATA] = Tcl_NewListObj( Rows*Cols, subitems );
1122  Tcl_SetListObj( obj_result,IT_SIZE, items );
1123  Tcl_Free( (char*)subitems );
1124  return TCL_OK;
1125}
1126
1127/*
1128 * Fill in obj_result the content of the serie variable.
1129 *
1130 */
1131
1132int Tol_GetSerieContent(Tcl_Interp * interp,
1133                        int objc,
1134                        Tcl_Obj *CONST objv[],
1135                        Tcl_Obj * obj_result)
1136{
1137  const BSyntaxObject* var = Tol_ResolveObject(interp,
1138                                               objv[0],
1139                                               obj_result/*,
1140                                               GraSerie()*/);
1141  if (!var) {
1142    return TCL_ERROR;
1143  }
1144
1145  // parse dates arguments
1146 
1147  BDate I0, I1;
1148  int tcl_code;
1149
1150  BUserTimeSerie * serie = (BUserTimeSerie*)var;
1151  serie->ReadData();
1152
1153  if (objc == 1) {
1154    I0 = serie->FirstDate();
1155    I1 = serie->LastDate();
1156  } else {
1157    tcl_code = Tol_ParseDate(interp,Tcl_GetString(objv[1]),I0);
1158    if (tcl_code != TCL_OK) {
1159      Tcl_AppendObjToObj(obj_result,Tcl_GetObjResult(interp));
1160      return TCL_ERROR;
1161    }
1162    if (objc == 3) {
1163      tcl_code = Tol_ParseDate(interp,Tcl_GetString(objv[2]),I1);
1164      if (tcl_code != TCL_OK) {
1165        Tcl_AppendObjToObj(obj_result,Tcl_GetObjResult(interp));
1166        return TCL_ERROR;
1167      }
1168    }
1169  }
1170 
1171  if ( !I0.HasValue() )
1172    I0 = BDate::DefaultFirst();
1173  if ( !I1.HasValue() )
1174    I1 = BDate::DefaultLast();
1175
1176  BUserTimeSet * tms;
1177  Tcl_Obj ** obj_array;
1178  int length;
1179
1180  char buffer[1024];
1181
1182  tms = serie->Dating();
1183
1184  if ( !tms ) {
1185    Tcl_AppendStringsToObj(obj_result,"Serie \"",
1186                           Tcl_GetString(objv[0]),
1187                           "\" does not have dating", NULL);
1188    return TCL_ERROR;
1189  }
1190
1191  // ajustamos el intervalo de fechas al fechado
1192
1193  I0 = tms->FirstNoLess(I0);
1194  I1 = tms->FirstNoGreat(I1);
1195  length = tms->Difference(I0,I1)+1;
1196  if ( length <= 0 ) {
1197    Tcl_SetStringObj(obj_result,
1198                     "last date must be greater or equal than first",-1);
1199    return TCL_ERROR;
1200  }
1201
1202  BDat  value;
1203  BText tmp;
1204  Tcl_Obj * subitems[2];
1205
1206  // ++ because we identify the TimeSet as the first element
1207
1208  ++length;
1209  obj_array = (Tcl_Obj**)ckalloc(length*sizeof(Tcl_Obj*));
1210
1211  //tmp = tms->Identify();
1212  GetName(tms, tmp);
1213  obj_array[0] = Tcl_NewStringObj(tmp,-1);
1214  for ( int i = 1; i < length; i++ ) {
1215    tmp = I0.GetText();
1216    subitems[0] = Tcl_NewStringObj(tmp,-1);
1217#if defined(_TOL_FROZEN_)
1218    value = (*serie)[I0];
1219#else
1220    value = (*serie)(I0);
1221#endif
1222    if ( value.IsKnown() )
1223      subitems[1] = Tcl_NewDoubleObj(value.Value());
1224    else
1225      subitems[1] = Tcl_NewStringObj("?",-1);
1226    obj_array[i] = Tcl_NewListObj(2,subitems);
1227    I0 += tms;
1228
1229    sprintf(buffer,"%d",i);
1230    Tcl_VarEval(interp, "puts ", buffer, NULL);
1231  }
1232  Tcl_SetListObj(obj_result,length,obj_array);
1233  Tcl_Free( (char*)obj_array );
1234  return TCL_OK;
1235}
1236
1237int Tol_ParseDate(Tcl_Interp * interp, char * what, BDate & date)
1238{
1239  int    year, month, day, hour, min;
1240  double sec;
1241 
1242  int tcl_code;
1243  Tcl_Obj * tcl_result;
1244  int objc;
1245  Tcl_Obj ** objv;
1246
1247  month = day = 1;
1248  hour  = min = 0;
1249  sec   = 0.0;
1250  char re_pat[] = "{^(?:y([0-9]+)(?:m([0-9]+))?(?:d([0-9]+))?)$}";
1251
1252  tcl_code = Tcl_VarEval(interp, "regexp -inline ", re_pat, " ",what, NULL);
1253  if ( tcl_code != TCL_OK )
1254    return TCL_ERROR;
1255  tcl_result = Tcl_DuplicateObj(Tcl_GetObjResult(interp));
1256  /* this should be a valid list, unless Tcl be corrupt */
1257  Tcl_ListObjGetElements(interp,tcl_result,&objc,&objv);
1258  if ( objc == 0 ) {
1259    Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
1260                           "invalid date: \"",what,"\"",NULL);
1261    Tcl_DecrRefCount(tcl_result);
1262    return TCL_ERROR;
1263  }
1264
1265  /* and objc must be 4 */
1266
1267  Tcl_GetIntFromObj(interp,objv[1],&year);
1268  Tcl_GetIntFromObj(interp,objv[2],&month);
1269  Tcl_GetIntFromObj(interp,objv[3],&day);
1270
1271  /* now is save to release tcl_result */
1272
1273  Tcl_DecrRefCount(tcl_result);
1274
1275  date.PutDate(year,month,day);
1276  if ( !date.HasValue() ) {
1277    Tcl_ResetResult(interp);
1278    char buffer[1024];
1279    sprintf(buffer,"y%dm%dd%d",year,month,day);
1280    tcl_result = Tcl_GetObjResult(interp);
1281    Tcl_AppendStringsToObj(tcl_result,
1282                           what," = ",buffer," is valid but unknown",NULL);
1283    return TCL_ERROR;
1284  }
1285  return TCL_OK;
1286}
1287
1288/*
1289 * Set the language to be used  by TOL. Fill in obj_result the previous
1290 * language.
1291 *
1292 */
1293
1294int Tol_SetLanguage(Tcl_Interp * interp, Tcl_Obj * lang, Tcl_Obj * obj_result)
1295{
1296  BBool curLang = BText::Language();
1297  BIdiomEnum nextLang;
1298 
1299  char * strLang = Tcl_GetString( lang );
1300  if ( !strcasecmp( strLang, "es" ) )
1301    nextLang = BSPANISH;
1302  else {
1303    /* anything else will be assumed as english */
1304    nextLang = BENGLISH;
1305  }
1306  /* set the previous language as result */
1307  if ( curLang == BSPANISH )
1308    Tcl_SetStringObj( obj_result, "es", -1 );
1309  else
1310    Tcl_SetStringObj( obj_result, "en", -1 );
1311  /* tell TOL what language to use from now on */
1312  BText::PutLanguage( nextLang );
1313  return TCL_OK;
1314}
1315
1316/*
1317 * Return the language used  by TOL. Fill in obj_result the current
1318 * language.
1319 *
1320 */
1321
1322int Tol_GetLanguage(Tcl_Interp * interp, Tcl_Obj * obj_result)
1323{
1324  BBool curLang = BText::Language();
1325 
1326  if ( curLang == BSPANISH )
1327    Tcl_SetStringObj( obj_result, "es", -1 );
1328  else
1329    Tcl_SetStringObj( obj_result, "en", -1 );
1330  return TCL_OK;
1331}
1332
1333/*
1334 * Fill in obj_result the version info corresponding to tol
1335 *
1336 *   {major MajorNum minor MinorNum release ReleaseNum coment Comment}
1337 *
1338 */
1339
1340int Tol_InfoVersion( Tcl_Interp * interp,  Tcl_Obj * obj_result )
1341{
1342#define VERSION_INFO_SIZE 4*2
1343 
1344  Tcl_Obj * items[VERSION_INFO_SIZE];
1345  char buffer[64];
1346
1347  /* Major Info */
1348  items[0] = Tcl_NewStringObj( "major", -1 );
1349  items[1] = Tcl_NewIntObj( VERSION_MAJOR );
1350  /* Minor Info */
1351  items[2] = Tcl_NewStringObj( "minor", -1 );
1352  items[3] = Tcl_NewIntObj( VERSION_MINOR );
1353  /* Release Info */
1354  items[4] = Tcl_NewStringObj( "release", -1 );
1355  sprintf(buffer,"%d", VERSION_RELEASE);
1356  items[5] = Tcl_NewStringObj(buffer, -1);
1357  /* Comment Info */
1358  items[6] = Tcl_NewStringObj( "comment", -1 );
1359  items[7] = Tcl_NewStringObj(TOLVersionBuild(), -1 );
1360  /* asign the items to the result list */
1361  Tcl_SetListObj( obj_result, VERSION_INFO_SIZE, items );
1362  return TCL_OK;
1363}
1364
1365/*
1366 * Fill in obj_result the list of files included in TOL
1367 *
1368 */
1369
1370
1371int Tol_InfoIncluded (Tcl_Interp * interp,Tcl_Obj * obj_result)
1372{
1373  BList* lst = BSetFromFile::Compiled();
1374
1375  BText txt(LstText(lst,"","",","));
1376  return BList2TclList(interp,lst,obj_result,&GetPath,&HasNoSource);
1377}
1378
1379/* OJO con la declaracion de tmpSet */
1380
1381int Tol_InfoFile(Tcl_Interp * interp, Tcl_Obj * file,
1382                 Tcl_Obj * obj_result)
1383{
1384  Tcl_DString dstr;
1385  const BSyntaxObject * so;
1386
1387  Tcl_DStringInit(&dstr);
1388  Tcl_UtfToExternalDString(NULL,Tcl_GetString(file),-1,&dstr);
1389 
1390  BText fname(Tcl_DStringValue(&dstr));
1391  so = (const BSyntaxObject*)BSetFromFile::FindCompiled(fname);
1392  Tcl_DStringFree(&dstr);
1393  if (!so) {
1394    Tcl_AppendStringsToObj(obj_result,"file \"",
1395                           Tcl_GetString(file),
1396                           "\" isn't included", NULL );
1397    return TCL_ERROR;
1398  }
1399  Tcl_Obj * info[6];
1400  /* adicionar la informacion del subtype y si tiene algun set
1401   * como descendiente
1402   */
1403  BText soInfo(so->Info());
1404  BText soPath(so->SourcePath());
1405  BText soDesc(so->Description());
1406
1407  char * pch = soInfo;
1408  if (pch) pch = skipWhite(pch);
1409  else pch = "";
1410
1411  Tcl_ExternalToUtfDString(NULL,pch,-1,&dstr);
1412  info[0] = Tcl_NewStringObj(Tcl_DStringValue(&dstr), -1);
1413  Tcl_DStringFree(&dstr);
1414
1415  Tcl_ExternalToUtfDString(NULL,soPath,-1,&dstr);
1416  info[1] = Tcl_NewStringObj(Tcl_DStringValue(&dstr), -1);
1417  Tcl_DStringFree(&dstr);
1418
1419  Tcl_ExternalToUtfDString(NULL,soDesc,-1,&dstr);
1420  info[2] = Tcl_NewStringObj(Tcl_DStringValue(&dstr), -1);
1421  Tcl_DStringFree(&dstr);
1422
1423  /* HAS SUBSET */
1424  BSet * ptrSet = &(((BUserSet*)so)->Contens());
1425  int tmpCard = ptrSet->Card();
1426  int j;
1427  for (j=1; j<=tmpCard; ++j )
1428    if (ContainerGetSet((*ptrSet)[j]))
1429      break;
1430  info[3] = Tcl_NewIntObj(j<=tmpCard);
1431   
1432  /* SUBTYPE INFO */
1433  info[4] = Tcl_NewIntObj( ptrSet->SubType() );
1434  /* STRUCTURE */
1435  info[5] = Tcl_NewStringObj( NULL, 0 );
1436  Tcl_SetListObj(obj_result, 6, info);
1437  return TCL_OK;
1438}
1439
1440/*
1441 * Fill in obj_result the result of evaluating including the file
1442 * given as argument: the absolute path.
1443 *
1444 */
1445
1446int Tol_IncludeFile(Tcl_Interp * interp,Tcl_Obj * obj_file,Tcl_Obj * obj_result)
1447{
1448  Tcl_DString dstr;
1449  BText fName;
1450
1451  Tcl_DStringInit(&dstr);
1452  fName = Tcl_UtfToExternalDString(NULL,Tcl_GetString(obj_file),-1,&dstr);
1453  BSetFromFile* uSet = (BSetFromFile*)BSetFromFile::FindCompiled(fName);
1454  Tcl_DStringFree(&dstr);
1455
1456  if(uSet) {
1457    DESTROY(uSet);
1458  }
1459  IncludeFile(fName);
1460  return TCL_OK;
1461}
1462
1463int Tol_DecompileFile( Tcl_Interp * interp,
1464                       Tcl_Obj * obj_file,
1465                       Tcl_Obj * obj_result )
1466{
1467  Tcl_DString dstr;
1468  BText fName;
1469
1470  Tcl_DStringInit(&dstr);
1471  fName = Tcl_UtfToExternalDString(NULL,Tcl_GetString(obj_file),-1,&dstr);
1472  BSetFromFile* uSet = (BSetFromFile*)BSetFromFile::FindCompiled(fName);
1473  Tcl_DStringFree(&dstr);
1474
1475  if(uSet) {
1476    DESTROY(uSet);
1477  } else {
1478    Tcl_AppendStringsToObj( obj_result, "file '",
1479                            Tcl_GetString(obj_file),
1480                            "' is not compiled", NULL );
1481    return TCL_ERROR;
1482  }
1483  if ( uSet ) {
1484    Tcl_AppendStringsToObj( obj_result, "could not decompile file '",
1485                            Tcl_GetString(obj_file), "'", NULL );
1486    return TCL_ERROR;
1487  }
1488  return TCL_OK;
1489}
1490/*
1491 *
1492 * Fill in obj_result the list of grammars defined in TOL
1493 *
1494 */
1495
1496int Tol_SetGrammarsObj(Tcl_Interp * interp, Tcl_Obj * obj_result )
1497{
1498
1499  BList* lstGra = BGrammar::Instances();
1500
1501  if (BList2TclList(interp,lstGra,obj_result,&GetName,&ExcludeAnything)==TCL_OK) {
1502    Tcl_Obj * name = Tcl_NewStringObj("Anything", -1);
1503    if (Tcl_ListObjAppendElement(interp,obj_result,name) != TCL_OK) {
1504      Tcl_AppendObjToObj(obj_result,Tcl_GetObjResult(interp));
1505      return TCL_ERROR;
1506    }
1507    if (QuickSort(interp,obj_result) != TCL_OK) {
1508      Tcl_AppendObjToObj(obj_result,Tcl_GetObjResult(interp));
1509      return TCL_ERROR;
1510    }
1511    return TCL_OK;
1512  }
1513  Tcl_AppendObjToObj(obj_result,Tcl_GetObjResult(interp));
1514  return TCL_ERROR;
1515}
1516
1517/*
1518 *
1519 * Fill in obj_result the description of gra_name.
1520 *
1521 */
1522
1523int Tol_SetGrammarDescObj(Tcl_Interp * interp, Tcl_Obj * gra_name,
1524                          Tcl_Obj * obj_result )
1525{
1526  BGrammar * gra = BGrammar::FindByName(Tcl_GetString(gra_name));
1527
1528  if (gra) {
1529    BText desc(gra->Description());
1530    Tcl_SetStringObj(obj_result, desc, -1);
1531    return TCL_OK;
1532  }
1533  Tcl_AppendStringsToObj( obj_result, "\"",
1534                          Tcl_GetString(gra_name),
1535                          "\" isn't a grammar", NULL );
1536  return TCL_ERROR;
1537}
1538
1539/*
1540 *  Tol_FillFunctionInfo --
1541 *
1542 *    Used in Tol_SetFunctionsObj & Tol_SetFunctionInfoObj to return the info
1543 *    for the function requested.
1544 */
1545
1546static
1547int Tol_FillFunctionInfo(BOperator * opr, Tcl_Obj * obj_result)
1548{
1549  Tcl_Obj * info[3];
1550  Tcl_DString dstr_info;
1551  Tcl_DString dstr;
1552
1553  Tcl_DStringInit(&dstr_info);
1554  BText args(opr->Arguments());
1555 
1556  if(args.Last()!='}') // name doesn't comes within the arguments expression
1557  {   
1558      // grammar name
1559      Tcl_DStringAppend(&dstr_info, opr->Grammar()->Name(), -1);
1560      Tcl_DStringAppend(&dstr_info, " ", -1);
1561      // function name
1562      Tcl_DStringInit(&dstr);
1563      Tcl_ExternalToUtfDString(NULL, opr->FullName(), -1, &dstr);
1564      Tcl_DStringAppend(&dstr_info, Tcl_DStringValue(&dstr), -1);
1565      Tcl_DStringFree(&dstr);
1566  }
1567
1568  Tcl_ExternalToUtfDString(NULL,args.String(),-1,&dstr);
1569  Tcl_DStringAppend(&dstr_info, Tcl_DStringValue(&dstr), -1);
1570  Tcl_DStringFree(&dstr);
1571  info[0] = Tcl_NewStringObj(Tcl_DStringValue(&dstr_info), -1);
1572  Tcl_DStringFree(&dstr_info);
1573  Tcl_ExternalToUtfDString(NULL,opr->SourcePath(),-1,&dstr);
1574  info[1] = Tcl_NewStringObj(Tcl_DStringValue(&dstr), -1);
1575  Tcl_DStringFree(&dstr);
1576  Tcl_ExternalToUtfDString(NULL,opr->Description(),-1,&dstr);
1577  info[2] = Tcl_NewStringObj(Tcl_DStringValue(&dstr), -1);
1578  Tcl_DStringFree(&dstr);
1579  Tcl_SetListObj(obj_result, 3, info);
1580  return TCL_OK;
1581}
1582
1583/*
1584 *
1585 * Fill in obj_result the functions defined for grammar gra_name.  If gra_name
1586 * is a list it is considered as an object reference {type ?name? i1 ... ik}
1587 *
1588 */
1589
1590int Tol_SetFunctionsObj (Tcl_Interp * interp, Tcl_Obj * gra_name,
1591                         Tcl_Obj * obj_result)
1592{
1593  int length = 0;
1594 
1595  if (Tcl_ListObjLength(interp,gra_name,&length)!=TCL_OK) {
1596    Tcl_AppendObjToObj(obj_result,Tcl_GetObjResult(interp));
1597    return TCL_ERROR;
1598  }
1599  if (length>1) {
1600    const BSyntaxObject *syn;
1601    if (!(syn=Tol_ResolveObject(interp, gra_name, obj_result))) {
1602      return TCL_ERROR;
1603    }
1604   
1605    if (syn->Grammar() != GraCode()) {
1606      Tcl_AppendStringsToObj(obj_result, "'", Tcl_GetString(gra_name),
1607                             "' is not a function object", NULL);
1608      return TCL_ERROR;
1609    }
1610    BOperator * opr =  ((BGraContens<BCode>*)syn)->Contens().Operator();
1611    return Tol_FillFunctionInfo(opr, obj_result);
1612  }
1613  /* gra_name should be a grammar name */
1614  if (!strcmp(Tcl_GetString(gra_name), "Anything")) {
1615    const BSpFunHash& spf = BSpecialFunction::Instances();
1616    BSpFunHash::const_iterator iter;
1617    for(iter=spf.begin(); iter!=spf.end(); iter++)
1618    {
1619      Tcl_ListObjAppendElement(interp, obj_result,
1620                               Tcl_NewStringObj(iter->second->Name(), -1));
1621    }
1622    if (QuickSort(interp,obj_result) != TCL_OK) {
1623      Tcl_AppendObjToObj(obj_result,Tcl_GetObjResult(interp));
1624      return TCL_ERROR;
1625    }
1626    return TCL_OK;
1627  }
1628
1629  BGrammar * gra = BGrammar::FindByName(Tcl_GetString(gra_name));
1630 
1631  if (gra) {
1632    BList * lstOper = gra->GetOperators();
1633    if (BList2TclList(interp,lstOper,obj_result,&GetName) != TCL_OK) {
1634      Tcl_AppendObjToObj(obj_result,Tcl_GetObjResult(interp));
1635      DESTROY(lstOper);
1636      return TCL_ERROR;
1637    }
1638    DESTROY(lstOper);
1639    if (QuickSort(interp,obj_result) != TCL_OK) {
1640      Tcl_AppendObjToObj(obj_result,Tcl_GetObjResult(interp));
1641      return TCL_ERROR;
1642    }
1643    return TCL_OK;
1644  }
1645
1646  Tcl_AppendStringsToObj(obj_result, "'",
1647                         Tcl_GetString(gra_name),
1648                         "' isn't a grammar", NULL);
1649  return TCL_ERROR;
1650}
1651
1652static
1653BOperator* TT_FindOperator( const BGrammar *G, const char *expr )
1654{
1655  BOperator* opr = G->FindOperator( expr );
1656  if ( opr ) {
1657    return opr;
1658  }
1659  bool oldEnabled = BOut::Disable();
1660  BSyntaxObject* obj = GraCode( )->BGrammar::LeftEvaluateExpr( expr );
1661  if( oldEnabled ) { BOut::Enable( ); }
1662  BUserCode *uc = dynamic_cast<BUserCode*>( obj );
1663 
1664  return
1665    ( uc && ( uc->Contens().Grammar( ) == G ) ) ? uc->Contens().Operator( ) : NULL;
1666}
1667
1668/*
1669 * Fill in obj_result the function's prototype and description
1670 * for a given function in a given grammar.
1671 *
1672 */
1673
1674int Tol_SetFunctionInfoObj (Tcl_Obj * gra_name,
1675                            Tcl_Obj * fun_name,
1676                            Tcl_Obj * obj_result)
1677{
1678  Tcl_DString dstr;
1679  Tcl_Obj * info[3];
1680
1681  if (!strcmp(Tcl_GetString(gra_name), "Anything")) {
1682    Tcl_DStringInit(&dstr);
1683    Tcl_UtfToExternalDString(NULL,Tcl_GetString(fun_name),-1,&dstr);
1684    const BSpecialFunction * spf = BSpecialFunction::Get(Tcl_DStringValue(&dstr));
1685    Tcl_DStringFree(&dstr);
1686    if (spf) {
1687      char * name, * args;
1688      size_t len;
1689     
1690      name = ((BText&)spf->Name()).Buffer();
1691      args = ((BText&)spf->Arguments()).Buffer();
1692      len = strlen(args);
1693      if(!len || args[len-1]!='}') {
1694        info[0] = Tcl_NewStringObj("Anything ", -1);
1695        Tcl_AppendStringsToObj(info[0],name,args,NULL);
1696      } else {
1697        info[0] = Tcl_NewStringObj("", -1);;
1698        Tcl_AppendStringsToObj(info[0],args,NULL);
1699      }
1700      info[1] = Tcl_NewStringObj("",-1);
1701      Tcl_ExternalToUtfDString(NULL,spf->Description(),-1,&dstr);
1702      info[2] = Tcl_NewStringObj(Tcl_DStringValue(&dstr), -1);
1703      Tcl_DStringFree(&dstr);
1704      Tcl_SetListObj(obj_result, 3, info);
1705      return TCL_OK;
1706    }
1707    Tcl_AppendStringsToObj( obj_result, "\"",
1708                            Tcl_GetString(fun_name),
1709                            "\" isn't a function in grammar Anything", NULL );
1710  } else {
1711    BGrammar * gra = BGrammar::FindByName(Tcl_GetString(gra_name));
1712 
1713    if (gra) {
1714      Tcl_DStringInit(&dstr);
1715      Tcl_UtfToExternalDString( NULL, Tcl_GetString( fun_name ), -1, &dstr );
1716      BOperator* opr = TT_FindOperator( gra, Tcl_DStringValue( &dstr ) );
1717      Tcl_DStringFree(&dstr);
1718      if (opr) {
1719        return Tol_FillFunctionInfo(opr, obj_result);
1720      }
1721      // release the previous use of dstr
1722      //Tcl_DStringFree(&dstr);
1723      Tcl_AppendStringsToObj( obj_result, "\"",
1724                              Tcl_GetString(fun_name),
1725                              "\" isn't a function in grammar ",
1726                              Tcl_GetString(gra_name), NULL );
1727    } else
1728      Tcl_AppendStringsToObj( obj_result, "\"",
1729                              Tcl_GetString(gra_name),
1730                              "\" isn't a grammar", NULL );
1731  }
1732  return TCL_ERROR;
1733}
1734
1735/* ojo info debe tener espacio para 7 Tcl_Obj como maximo */
1736/* retorna cuantos Tcl_Obj creo */
1737
1738int SynObj2TclObj( const BSyntaxObject * var, Tcl_Obj * info[] )
1739{
1740  Tcl_DString dstr;
1741  int infoc;
1742
1743  Tcl_DStringInit(&dstr);
1744
1745  /* GRAMMAR */
1746  info[0] = Tcl_NewStringObj(var->Grammar()->Name().String(), -1);
1747   
1748  /* NAME */
1749  BText synname;
1750 
1751  GetName(var, synname);
1752  Tcl_ExternalToUtfDString(NULL,synname,-1,&dstr);
1753  info[1] = Tcl_NewStringObj(Tcl_DStringValue(&dstr), -1);
1754  Tcl_DStringFree(&dstr);
1755   
1756  /* REST OF FIELDS */
1757 
1758  BText varInfo(var->Info());
1759  BText varPath(var->SourcePath());
1760  BText varDesc(var->Description());
1761 
1762  /* OBJECT CONTENT */
1763  char * pch = varInfo;
1764  if (pch) pch = skipWhite(pch);
1765  else pch = "";
1766 
1767  Tcl_ExternalToUtfDString(NULL,pch,-1,&dstr);
1768  info[2] = Tcl_NewStringObj(Tcl_DStringValue(&dstr), -1);
1769  Tcl_DStringFree(&dstr);
1770 
1771  /* OBJECT PATH */
1772  Tcl_ExternalToUtfDString(NULL,varPath,-1,&dstr);
1773  info[3] = Tcl_NewStringObj(Tcl_DStringValue(&dstr), -1);
1774  Tcl_DStringFree(&dstr);
1775 
1776  /* OBJECT DESCRIPTION */
1777  Tcl_ExternalToUtfDString(NULL,varDesc,-1,&dstr);
1778  info[4] = Tcl_NewStringObj(Tcl_DStringValue(&dstr), -1);
1779  Tcl_DStringFree(&dstr);
1780 
1781#ifdef ISFILE_IMPLEMENTED
1782  info[5] = Tcl_NewIntObj(var->IsFile());
1783#else
1784  info[5] = Tcl_NewIntObj(0);
1785#endif
1786  //info[6] = Tcl_NewIntObj(var->System());
1787  BSet *ptrSet;
1788  if ((ptrSet=ContainerGetSet(var))) {
1789    /* HAS SUBSET */
1790    int tmpCard = ptrSet->Card();
1791    int j;
1792    for (j=1; j<=tmpCard; ++j )
1793      if ( (*ptrSet)[j]->Grammar()==GraSet() )
1794        break;
1795    info[6] = Tcl_NewIntObj(j<=tmpCard);
1796     
1797    /* SUBTYPE */
1798    info[7] = Tcl_NewIntObj( ptrSet->SubType() );
1799     
1800    /* STRUCTURE */
1801    if ( ptrSet->Struct() ) {
1802      BText btxt( ptrSet->Struct()->Name() );
1803      Tcl_ExternalToUtfDString(NULL,btxt,-1,&dstr);
1804      info[8] = Tcl_NewStringObj( Tcl_DStringValue(&dstr), -1 );
1805      Tcl_DStringFree( &dstr );
1806    } else
1807      info[8] = Tcl_NewStringObj( NULL, 0 );
1808    infoc = 9;
1809  } else
1810    infoc = 6;
1811 
1812  return infoc;
1813}
1814
1815int Tol_SetVariableInfoObj (Tcl_Obj * gra_name,
1816                            Tcl_Obj * var_name,
1817                            Tcl_Obj * obj_result);
1818
1819/*!
1820 * Fill in obj_result the variables defined for grammar gra_name.
1821 * Or the element info if gra_name is a reference of an element
1822 * of a global container.
1823 */
1824int Tol_SetVariablesObj (Tcl_Interp *interp, Tcl_Obj *gra_name,
1825                         Tcl_Obj *obj_result)
1826{
1827  const BSyntaxObject *syn ;
1828 
1829  int length = 0;
1830  Tcl_Obj ** items;
1831  int tcl_code;
1832 
1833  if (Tcl_ListObjLength(interp,gra_name,&length)!=TCL_OK) {
1834    Tcl_AppendObjToObj(obj_result,Tcl_GetObjResult(interp));
1835    return TCL_ERROR;
1836  }
1837  if (length!=1) {
1838    if (length == 2) {
1839      tcl_code = Tcl_ListObjGetElements(interp,gra_name,&length,&items);
1840      assert(tcl_code == TCL_OK);
1841      if (strcmp(Tcl_GetString(items[0]),"Console"))
1842        return Tol_SetVariableInfoObj(items[0], items[1], obj_result);
1843    }
1844    if (!(syn=Tol_ResolveObject(interp, gra_name, obj_result))) {
1845      return TCL_ERROR;
1846    }
1847//    Tcl_DString dstr;
1848    Tcl_Obj * info[9];
1849    int infoc;
1850   
1851    infoc = SynObj2TclObj(syn, info);
1852    Tcl_SetListObj(obj_result,infoc,info);
1853    return TCL_OK;
1854  }
1855  BGrammar *gra = BGrammar::FindByName(Tcl_GetString(gra_name));
1856  if (!gra) {
1857    Tcl_AppendStringsToObj( obj_result, "'",
1858                            Tcl_GetString(gra_name),
1859                            "' isn't a grammar", NULL );
1860    return TCL_ERROR;
1861  }
1862  BList * lstVar = gra->GetVariables();
1863  if (BList2TclList(interp,lstVar,obj_result,&GetIdentify) != TCL_OK) {
1864    Tcl_AppendObjToObj(obj_result,Tcl_GetObjResult(interp));
1865    DESTROY(lstVar);
1866    return TCL_ERROR;
1867  }
1868  DESTROY(lstVar);
1869  if (QuickSort(interp,obj_result) != TCL_OK) {
1870    Tcl_AppendObjToObj(obj_result,Tcl_GetObjResult(interp));
1871    return TCL_ERROR;
1872  }
1873  return TCL_OK;
1874}
1875
1876/*
1877 * Fill in obj_result the variables's description for a given variable
1878 * in a given grammar.
1879 *
1880 */
1881
1882int Tol_SetVariableInfoObj (Tcl_Obj * gra_name,
1883                            Tcl_Obj * var_name,
1884                            Tcl_Obj * obj_result)
1885{
1886  BGrammar * gra = BGrammar::FindByName(Tcl_GetString(gra_name));
1887  Tcl_DString dstr;
1888 
1889  Tcl_DStringInit(&dstr);
1890  if (gra) {
1891    Tcl_UtfToExternalDString(NULL,Tcl_GetString(var_name),-1,&dstr);
1892    const BSyntaxObject* var = gra->FINDVARIABLE(Tcl_DStringValue(&dstr));
1893    Tcl_DStringFree(&dstr);
1894
1895    if (var) {
1896      Tcl_Obj * info[9];
1897      int infoc;
1898      infoc = SynObj2TclObj( var, info );
1899      Tcl_SetListObj(obj_result,infoc,info);
1900//#define __INFO_PRINT_NREFS__
1901#ifdef __INFO_PRINT_NREFS__
1902      printf("NREF = %d\n", var->NRefs());
1903#endif
1904      return TCL_OK;
1905    }
1906    Tcl_AppendStringsToObj( obj_result, "\"",
1907                            Tcl_GetString(var_name),
1908                            "\" isn't a variable in grammar ",
1909                            Tcl_GetString(gra_name), NULL );
1910  } else
1911    Tcl_AppendStringsToObj( obj_result, "\"",
1912                            Tcl_GetString(gra_name),
1913                            "\" isn't a grammar", NULL );
1914  return TCL_ERROR;
1915}
1916
1917/*
1918 * We must be sure that the strings use 7 bit ASCII chararters.
1919 * Otherwise we must take care of the Utf representation.
1920 *
1921 */
1922
1923static
1924int StrObjCompare(const void * O1, const void * O2)
1925{
1926  char * str1 = (*(Tcl_Obj**)O1)->bytes;
1927  char * str2 = (*(Tcl_Obj**)O2)->bytes;
1928  int check1, check2;
1929
1930  check1 = isalpha(str1[0]);
1931  check2 = isalpha(str2[0]);
1932
1933  if ( check1 && !check2 )
1934    return 1;
1935  if ( check2 && !check1 )
1936    return -1;
1937  return strcmp(str1,str2);
1938}
1939
1940static
1941int QuickSort( Tcl_Interp * interp, Tcl_Obj * list )
1942{
1943  Tcl_Obj ** obj_array;
1944  int length;
1945
1946  if (Tcl_ListObjGetElements(interp, list, &length, &obj_array) != TCL_OK) {
1947    return TCL_ERROR;
1948  }
1949  qsort((void*)obj_array, length, sizeof(Tcl_Obj*), &StrObjCompare);
1950  return TCL_OK;
1951}
1952
1953static
1954void Tol_HciWriter( const BText & str )
1955{
1956  Tcl_CmdInfo cmd_info;
1957
1958  if (TT_interp && Tcl_GetCommandInfo(TT_interp,"Tol_HciWriter",&cmd_info) ) {
1959    Tcl_DString dstr;
1960    Tcl_Obj * objv[2];
1961   
1962    Tcl_DStringInit(&dstr);
1963    Tcl_IncrRefCount(objv[0]=Tcl_NewStringObj("Tol_HciWriter",-1));
1964    Tcl_ExternalToUtfDString(NULL, ((BText&)str).Buffer(), -1, &dstr);
1965    Tcl_IncrRefCount(objv[1]=Tcl_NewStringObj(Tcl_DStringValue(&dstr), Tcl_DStringLength(&dstr)));
1966    Tcl_DStringFree(&dstr);
1967 
1968    int status = Tcl_EvalObjv(TT_interp, 2, objv, TCL_EVAL_GLOBAL);
1969    if (status != TCL_OK) {
1970      printf("message: %s\n", ((BText&)str).Buffer());
1971      printf("objv[1] : %s\n", Tcl_GetString(objv[1]));
1972      printf("%s\n", TT_interp->result);
1973    }
1974    /* release the objects */
1975    Tcl_DecrRefCount(objv[0]);
1976    Tcl_DecrRefCount(objv[1]);
1977  }
1978}
1979
1980void Tol_InstallHciWriter()
1981{
1982  BOut::PutHciWriter(Tol_HciWriter);
1983  BOut::PutLogHciWriter(Tol_HciWriter);
1984}
1985
1986static
1987void Tol_SerieChart(BList * series, const BText& FileName )
1988{
1989#define CMD_SERIECHART "Tol_SerieChartMethod"
1990#define GRP_NAME "__grptmp_chart__%d"
1991
1992  Tcl_CmdInfo cmd_info;
1993  static int id = 0;
1994
1995  if (TT_interp && Tcl_GetCommandInfo(TT_interp,CMD_SERIECHART,&cmd_info) ) {
1996    Tcl_DString dstr;
1997    Tcl_Obj * objv[3];
1998    Tcl_Obj * obj_result=Tcl_NewObj();
1999    int tcl_result;
2000    char grpname[1024];
2001   
2002    Tcl_IncrRefCount(obj_result);
2003
2004    // first create the group of series
2005    sprintf(grpname, GRP_NAME, ++id);
2006    tcl_result = Tol_CreateSerieGrp(TT_interp, grpname, series, obj_result);
2007    if (tcl_result==TCL_ERROR) {
2008      printf("%s -- error in Tol_CreateSerieGrp: %s\n", CMD_SERIECHART,
2009             Tcl_GetString(obj_result));
2010      Tcl_DecrRefCount(obj_result);
2011      return;
2012    }
2013    // release the obj_result
2014    Tcl_DecrRefCount(obj_result);   
2015    // chart command
2016    Tcl_IncrRefCount(objv[0]=Tcl_NewStringObj(CMD_SERIECHART,-1));
2017    // serie group argument
2018    Tcl_IncrRefCount(objv[1]=Tcl_NewStringObj(grpname,-1));   
2019    // file name argument
2020    Tcl_DStringInit(&dstr);
2021    Tcl_ExternalToUtfDString(NULL, ((BText&)FileName).Buffer(), -1, &dstr);
2022    Tcl_IncrRefCount(objv[2]=Tcl_NewStringObj(Tcl_DStringValue(&dstr), Tcl_DStringLength(&dstr)));
2023    Tcl_DStringFree(&dstr);
2024    int status = Tcl_EvalObjv(TT_interp, 3, objv, TCL_EVAL_GLOBAL);
2025    if (status != TCL_OK) {
2026      printf("%s -- error in Tcl_EvalObjv:\n", CMD_SERIECHART);
2027      printf("%s\n", TT_interp->result);
2028      printf("objv[1] : %s\n", Tcl_GetString(objv[1]));
2029      printf("objv[2] : %s\n", Tcl_GetString(objv[2]));
2030    }
2031    /* release the objects */
2032    for (int i=0; i<3; i++)
2033      Tcl_DecrRefCount(objv[i]);
2034    /* the group of series should be destroyied in the Hook */
2035    /*Tcl_VarEval(TT_interp, "tol::seriegrp destroy ", grpname, NULL);*/
2036  }
2037}
2038
2039int Tol_Tcl_Eval(char * script, const char ** result)
2040{
2041  int status;
2042 
2043  status = Tcl_Eval(TT_interp, script);
2044  *result = Tcl_GetStringResult(TT_interp);
2045  return status==TCL_OK;
2046}
2047
2048Tcl_Obj *TolObj2TclObj(BSyntaxObject *tolObj)
2049{
2050  const char *grammar = tolObj->Grammar()->Name().String();
2051
2052  if (!strcmp(grammar, "Text")) {
2053    const BText &value = Text(tolObj);
2054    return Tcl_NewStringObj(value.String(),-1);
2055  } else if (!strcmp(grammar, "Real")) {
2056    const BDat &value = Dat(tolObj);
2057    return Tcl_NewDoubleObj(value.Value());
2058  } else {
2059    return Tcl_NewStringObj(tolObj->Dump().String(),-1);   
2060  }
2061}
2062
2063int Tol_Tcl_EvalEx(const BSet &Args, const char ** result)
2064{
2065  int status;
2066  Tcl_Obj **objv;
2067  int card = Args.Card();
2068 
2069  if (!Args.Card()) {
2070    *result = "";
2071    status = TCL_OK;
2072  } else {
2073    objv = (Tcl_Obj**)Tcl_Alloc(sizeof(Tcl_Obj*)*card);
2074    for(int i=1; i<=card; i++) {
2075      objv[i-1] = TolObj2TclObj(Args[i]);
2076      Tcl_IncrRefCount(objv[i-1]);
2077    }
2078    status = Tcl_EvalObjv(TT_interp, card, objv, TCL_EVAL_GLOBAL);
2079    *result = Tcl_GetStringResult(TT_interp);
2080    for(int i=0; i<card; i++) {
2081      Tcl_DecrRefCount(objv[i]);
2082    }
2083  }
2084  return status==TCL_OK;
2085}
2086
2087int Tol_StopEvaluation()
2088{
2089  StopFlagOn();
2090  return TCL_OK;
2091}
2092
2093/*
2094 * Fill in obj_result the format .
2095 *
2096 */
2097
2098int Tol_LCFormat(Tcl_Interp*    interp,
2099                 Tcl_Obj *CONST obj_value,
2100                 Tcl_Obj *      obj_result)
2101{
2102  double value;
2103  char buffer[256];
2104 
2105  /* read the double value from tcl obj */
2106  if (Tcl_GetDoubleFromObj(TT_interp, obj_value, &value)==TCL_ERROR)
2107    {
2108      Tcl_AppendObjToObj(obj_result,Tcl_GetObjResult(interp));
2109      return TCL_ERROR;
2110    }
2111  lc_format(value, buffer);
2112  Tcl_AppendStringsToObj(obj_result, buffer, NULL);
2113  return TCL_OK;
2114}
2115
2116void Tol_InstallMethodsHook()
2117{
2118  InstallSerieChartHook(&Tol_SerieChart);
2119  InstallTclEval(&Tol_Tcl_Eval);
2120  InstallTclEvalEx(&Tol_Tcl_EvalEx);
2121}
Note: See TracBrowser for help on using the repository browser.