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

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

use FullName instead of Name

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