source: tol/toltcl/generic/toltcl.c @ 8d687fe

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

refs #994, #1404: implementing the command tol::checksyntax

git-svn-id: ​https://www.tol-project.org/svn/tolp/trunk@4124 be4846ae-f051-483a-831f-b64e7d08527f
  • Property mode set to 100644
File size: 50.6 KB
Line 
1/* toltcl.cpp: This file implements a Tcl interface to Tol.
2               GNU/tolTcl Library
3
4   Copyright (C) 2001, 2002, 2003 - Bayes Decisión, SL
5
6   This program is free software; you can redistribute it and/or modify
7   it under the terms of the GNU General Public License as published by
8   the Free Software Foundation; either version 2, or (at your option)
9   any later version.
10
11   This program is distributed in the hope that it will be useful,
12   but WITHOUT ANY WARRANTY; without even the implied warranty of
13   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
14   GNU General Public License for more details.
15
16   You should have received a copy of the GNU General Public License
17   along with this program; if not, write to the Free Software
18   Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
19   USA.
20 */
21
22#if defined(_MSC_VER)
23#  include <win_tolinc.h>
24#endif
25
26#include <string.h>
27#include <gsl/gsl_errno.h>
28
29#include <toltclInt.h>
30#include <toltcl.h>
31#include <tt_crash.h>
32
33#include <tol/tol_init.h>
34
35Tcl_Interp * TT_interp;
36
37static int Tol_InitKernelCmd _ANSI_ARGS_((ClientData clientData,
38                                          Tcl_Interp *interp,
39                                          int objc, Tcl_Obj *CONST objv[]));
40
41static int Tol_InitLibraryCmd _ANSI_ARGS_((ClientData clientData,
42                                           Tcl_Interp *interp,
43                                           int objc, Tcl_Obj *CONST objv[]));
44
45static int Tol_CheckSyntaxCmd _ANSI_ARGS_((ClientData clientData,
46                                           Tcl_Interp *interp,
47                                           int objc, Tcl_Obj *CONST objv[]));
48
49static int Tol_IncludeCmd _ANSI_ARGS_((ClientData clientData,
50                                       Tcl_Interp *interp,
51                                       int objc, Tcl_Obj *CONST objv[]));
52
53static int Tol_DecompileCmd _ANSI_ARGS_((ClientData clientData,
54                                         Tcl_Interp *interp,
55                                         int objc, Tcl_Obj *CONST objv[]));
56
57static int Tol_ConsoleCmd _ANSI_ARGS_((ClientData clientData,
58                                       Tcl_Interp *interp,
59                                       int objc, Tcl_Obj *CONST objv[]));
60
61static int Tol_ForAllChildCmd _ANSI_ARGS_((ClientData clientData,
62                                           Tcl_Interp *interp,
63                                           int objc, Tcl_Obj *CONST objv[]));
64
65static int Tol_ForEachCmd _ANSI_ARGS_((ClientData clientData,
66                                       Tcl_Interp *interp,
67                                       int objc, Tcl_Obj *CONST objv[]));
68
69static int Tol_TableSetCmd _ANSI_ARGS_((ClientData clientData,
70                                      Tcl_Interp *interp,
71                                      int objc, Tcl_Obj *CONST objv[]));
72
73static int Tol_TableMatCmd _ANSI_ARGS_((ClientData clientData,
74                                      Tcl_Interp *interp,
75                                      int objc, Tcl_Obj *CONST objv[]));
76
77static int Tol_TableCmd _ANSI_ARGS_((int ismat, ClientData clientData,
78                                     Tcl_Interp *interp,
79                                     int objc, Tcl_Obj *CONST objv[]));
80
81static int Tol_GetSerieCmd _ANSI_ARGS_((ClientData clientData,
82                                        Tcl_Interp *interp,
83                                        int objc, Tcl_Obj *CONST objv[]));
84
85static int Tol_SerieGrpCmd _ANSI_ARGS_((ClientData clientData,
86                                        Tcl_Interp *interp,
87                                        int objc, Tcl_Obj *CONST objv[]));
88
89static int Tol_LanguageCmd _ANSI_ARGS_((ClientData clientData,
90                                        Tcl_Interp *interp,
91                                        int objc, Tcl_Obj *CONST objv[]));
92
93static int Tol_InfoCmd _ANSI_ARGS_((ClientData clientData,
94                                    Tcl_Interp *interp,
95                                    int objc, Tcl_Obj *CONST objv[]));
96
97static int Tol_InfoStruct _ANSI_ARGS_((Tcl_Interp *interp,
98                                       int objc, Tcl_Obj *CONST objv[],
99                                       Tcl_Obj * obj_result));
100
101static int Tol_InfoPath _ANSI_ARGS_((Tcl_Interp *interp,
102                                     int objc, Tcl_Obj *CONST objv[],
103                                     Tcl_Obj * obj_result));
104
105static int Tol_InfoGrammars _ANSI_ARGS_((Tcl_Interp *interp,
106                                         int objc, Tcl_Obj *CONST objv[],
107                                         Tcl_Obj * obj_result));
108
109static int Tol_InfoPackages _ANSI_ARGS_((Tcl_Interp *interp,
110                                         int objc, Tcl_Obj *CONST objv[],
111                                         Tcl_Obj * obj_result));
112
113static int Tol_InfoFunctions _ANSI_ARGS_((Tcl_Interp *interp,
114                                          int objc, Tcl_Obj *CONST objv[],
115                                          Tcl_Obj * obj_result));
116
117static int Tol_InfoVariables _ANSI_ARGS_((Tcl_Interp *interp,
118                                          int objc,Tcl_Obj *CONST objv[],
119                                          Tcl_Obj * obj_result));
120
121static int Tol_GetMatrixCmd _ANSI_ARGS_((ClientData clientData,
122                                         Tcl_Interp *interp,
123                                         int objc, Tcl_Obj *CONST objv[]));
124
125static int Tol_TimeSetCmd _ANSI_ARGS_((ClientData clientData,
126                                       Tcl_Interp *interp,
127                                       int objc, Tcl_Obj *CONST objv[]));
128
129static int Tol_DateCmd _ANSI_ARGS_((ClientData clientData,
130                                    Tcl_Interp *interp,
131                                    int objc, Tcl_Obj *CONST objv[]));
132
133static int Tol_AutoCorrCmd _ANSI_ARGS_((ClientData clientData,
134                                        Tcl_Interp *interp,
135                                        int objc, Tcl_Obj *CONST objv[]));
136
137static int Tol_SerieStatCmd _ANSI_ARGS_((ClientData clientData,
138                                         Tcl_Interp *interp,
139                                         int objc, Tcl_Obj *CONST objv[]));
140
141static int Tol_StopEvalCmd  _ANSI_ARGS_((ClientData clientData,
142                                         Tcl_Interp *interp,
143                                         int objc, Tcl_Obj *CONST objv[]));
144
145static int Tol_LCFormatCmd  _ANSI_ARGS_((ClientData clientData,
146                                         Tcl_Interp *interp,
147                                         int objc, Tcl_Obj *CONST objv[]));
148
149DLLIMPORT gsl_error_handler_t * Tol_gsl_set_error_handler (gsl_error_handler_t * new_handler);
150DLLIMPORT const char * Tol_gsl_strerror (const int gsl_errno);
151
152/*
153 * TT_gsl_error_handler --
154 *
155 *    Tcl hook to a GSL error. This should be used only to detect where the gsl
156 *    errors are reported.
157 */
158
159static void TT_gsl_error_handler(const char * reason, const char * file, int line,
160                                 int gsl_errno)
161{
162  Tcl_CmdInfo cmd_info;
163  int status;
164
165  if (TT_interp && Tcl_GetCommandInfo(TT_interp,"::tol::gsl_error_handler",&cmd_info) ) {
166    Tcl_DString dstr;
167    Tcl_Obj * objv[5];
168   
169    Tcl_DStringInit(&dstr);
170    objv[0] = Tcl_NewStringObj("::tol::gsl_error_handler",-1);
171    Tcl_ExternalToUtfDString(NULL, reason, -1, &dstr);
172    objv[1] = Tcl_NewStringObj(Tcl_DStringValue(&dstr), Tcl_DStringLength(&dstr));
173    Tcl_DStringFree(&dstr);
174    Tcl_ExternalToUtfDString(NULL, file, -1, &dstr);
175    objv[2] = Tcl_NewStringObj(Tcl_DStringValue(&dstr), Tcl_DStringLength(&dstr));
176    Tcl_DStringFree(&dstr);
177    objv[3] = Tcl_NewIntObj(line);
178    Tcl_ExternalToUtfDString(NULL, Tol_gsl_strerror(gsl_errno), -1, &dstr);
179    objv[4] = Tcl_NewStringObj(Tcl_DStringValue(&dstr), Tcl_DStringLength(&dstr));
180    Tcl_DStringFree(&dstr);
181    status = Tcl_EvalObjv(TT_interp, 5, objv, TCL_EVAL_GLOBAL);
182    if (status != TCL_OK) {
183      printf("%s in file %s at line %d\n. str_ernno : %s",
184             reason, file, line, Tol_gsl_strerror(gsl_errno));
185      printf("interp : %s\n", TT_interp->result);
186    }
187  } 
188}
189
190
191/*
192 *----------------------------------------------------------------------
193 *
194 * Tol_InitKernelCmd --
195 *
196 *        Implements the new Tcl "::tol::initkernel ?lang ?vmode??" command.
197 *       
198 * Results:
199 *       A standard Tcl result
200 *
201 * Side effects:
202 *       None.
203 *
204 *----------------------------------------------------------------------
205 */
206
207static int
208Tol_InitKernelCmd(clientData, interp, objc, objv)
209     ClientData clientData;  /* Not used. */
210     Tcl_Interp *interp;     /* Current interpreter */
211     int objc;               /* Number of arguments */
212     Tcl_Obj *CONST objv[];  /* Argument objects */
213{
214  int lang;
215  char* vmode;
216  if (objc > 3) {
217    Tcl_AppendResult(interp, "wrong # args: should be \"",
218                     Tcl_GetString(objv[0]),"?lang ?vmode??\"", NULL);
219    return TCL_ERROR;
220  }
221  if ( objc >= 2 ) {
222    if ( !strcasecmp("es", Tcl_GetString( objv[1] ) ) ) {
223      lang = 1;
224    } else if ( !strcasecmp("en", Tcl_GetString( objv[1] ) ) ) {
225      lang = 0;
226    } else {
227      lang = -1;
228    }
229    if ( objc == 3 ) {
230      vmode = Tcl_GetString( objv[2] );
231    } else {
232      vmode = NULL;
233    }
234  } else {
235    lang = -1;
236    vmode = NULL;
237  }
238
239  if ( !TOLHasBeenInitialized( ) ) {
240    /* printf( "****TOL no esta inicializado %d****\n", lang ); */
241    /*
242     * Initialize kernel
243     */
244   
245    InitTolKernel(Tcl_GetNameOfExecutable(), lang, vmode&&vmode[0]?vmode:NULL);
246   
247    /*
248     * this should only be called to find out where the GSL errors are generated
249     */
250   
251    Tol_gsl_set_error_handler(&TT_gsl_error_handler);
252  } else {
253    /* printf( "****TOL esta inicializado****\n" ); */
254  }
255 
256  /*
257   * Install tol::* commands
258   */
259
260  Tcl_CreateObjCommand( interp, "::tol::initlibrary", Tol_InitLibraryCmd,
261                        (ClientData)NULL, (Tcl_CmdDeleteProc *)NULL );
262
263  Tcl_CreateObjCommand( interp, "::tol::checksyntax", Tol_CheckSyntaxCmd,
264                        (ClientData)NULL, (Tcl_CmdDeleteProc *)NULL );
265
266  Tcl_CreateObjCommand( interp, "::tol::include", Tol_IncludeCmd,
267                        (ClientData)NULL, (Tcl_CmdDeleteProc *)NULL );
268
269  Tcl_CreateObjCommand( interp, "::tol::decompile", Tol_DecompileCmd,
270                        (ClientData)NULL, (Tcl_CmdDeleteProc *)NULL );
271
272  Tcl_CreateObjCommand( interp, "::tol::info", Tol_InfoCmd,
273                        (ClientData)NULL, (Tcl_CmdDeleteProc *)NULL );
274
275  Tcl_CreateObjCommand( interp, "::tol::language", Tol_LanguageCmd,
276                        (ClientData)NULL, (Tcl_CmdDeleteProc *)NULL );
277
278  Tcl_CreateObjCommand( interp, "::tol::console", Tol_ConsoleCmd,
279                        (ClientData)NULL, (Tcl_CmdDeleteProc *)NULL );
280
281  Tcl_CreateObjCommand( interp, "::tol::forallchild", Tol_ForAllChildCmd,
282                        (ClientData)NULL, (Tcl_CmdDeleteProc *)NULL );
283
284  Tcl_CreateObjCommand( interp, "::tol::foreach", Tol_ForEachCmd,
285                        (ClientData)NULL, (Tcl_CmdDeleteProc *)NULL );
286
287  Tcl_CreateObjCommand( interp, "::tol::tableset", Tol_TableSetCmd,
288                        (ClientData)NULL, (Tcl_CmdDeleteProc *)NULL );
289
290  Tcl_CreateObjCommand( interp, "::tol::tablematrix", Tol_TableMatCmd,
291                        (ClientData)NULL, (Tcl_CmdDeleteProc *)NULL );
292
293  Tcl_CreateObjCommand( interp, "::tol::getserie", Tol_GetSerieCmd,
294                        (ClientData)NULL, (Tcl_CmdDeleteProc *)NULL );
295
296  Tcl_CreateObjCommand( interp, "::tol::seriegrp", Tol_SerieGrpCmd,
297                        (ClientData)NULL, (Tcl_CmdDeleteProc *)NULL );
298
299  Tcl_CreateObjCommand( interp, "::tol::matrix", Tol_GetMatrixCmd,
300                        (ClientData)NULL, (Tcl_CmdDeleteProc *)NULL );
301
302  Tcl_CreateObjCommand( interp, "::tol::timeset", Tol_TimeSetCmd,
303                        (ClientData)NULL, (Tcl_CmdDeleteProc *)NULL );
304
305  Tcl_CreateObjCommand( interp, "::tol::date", Tol_DateCmd,
306                        (ClientData)NULL, (Tcl_CmdDeleteProc *)NULL );
307
308  Tcl_CreateObjCommand( interp, "::tol::autocor", Tol_AutoCorrCmd,
309                        (ClientData)NULL, (Tcl_CmdDeleteProc *)NULL );
310
311  Tcl_CreateObjCommand( interp, "::tol::seriestat", Tol_SerieStatCmd,
312                        (ClientData)NULL, (Tcl_CmdDeleteProc *)NULL );
313 
314  Tcl_CreateObjCommand( interp, "::tol::stop", Tol_StopEvalCmd,
315                        (ClientData)NULL, (Tcl_CmdDeleteProc *)NULL );
316
317  Tcl_CreateObjCommand( interp, "::tol::lc_format", Tol_LCFormatCmd,
318                        (ClientData)NULL, (Tcl_CmdDeleteProc *)NULL );
319  return TCL_OK;
320}
321
322
323/*
324 *----------------------------------------------------------------------
325 *
326 * Tol_InitLibraryCmd --
327 *
328 *        Implements the new Tcl "::tol::initlibrary" command.
329 *
330 * Results:
331 *       A standard Tcl result
332 *
333 * Side effects:
334 *       None.
335 *
336 *----------------------------------------------------------------------
337 */
338
339static int
340Tol_InitLibraryCmd(clientData, interp, objc, objv)
341     ClientData clientData;  /* Not used. */
342     Tcl_Interp *interp;     /* Current interpreter */
343     int objc;               /* Number of arguments */
344     Tcl_Obj *CONST objv[];  /* Argument objects */
345{
346  int loadIni;
347  int status;
348
349  if ( objc != 2 ) {
350    Tcl_AppendResult(interp, "wrong # args: should be \"",
351                     Tcl_GetString(objv[0]), " 0|1\"", NULL);
352    return TCL_ERROR;
353  }
354 
355  if ( (status = Tcl_GetIntFromObj( interp, objv[1], &loadIni )) == TCL_OK ) {
356    LoadInitLibrary( loadIni );
357  }
358  return status;
359}
360
361
362/*
363 *----------------------------------------------------------------------
364 *
365 * Tol_CheckSyntaxCmd --
366 *
367 *      Implements the new Tcl "::tol::checksyntax" command.
368 *
369 * Results:
370 *
371 *      Returns the syntax error found in the tol expression given as
372 *      argument. If no error is found then the empty string is
373 *      returned.
374 *
375 * Side effects:
376 *      None.
377 *
378 *----------------------------------------------------------------------
379 */
380
381static int
382Tol_CheckSyntaxCmd(clientData, interp, objc, objv)
383     ClientData clientData;  /* Not used. */
384     Tcl_Interp *interp;             /* Current interpreter */
385     int objc;                                 /* Number of arguments */
386     Tcl_Obj *CONST objv[];  /* Argument objects */
387{
388  Tcl_Obj * obj_result= Tcl_NewObj();
389  int tcl_result;
390 
391  if (objc != 2) {
392    Tcl_SetStringObj(obj_result,
393                     "wrong # args: should be \"::tol::checksyntax tolcode\"",
394                     -1);
395    tcl_result = TCL_ERROR;
396  } else
397    tcl_result = Tol_CheckSyntax( interp, objv[1], obj_result );
398  Tcl_SetObjResult( interp, obj_result );
399  return tcl_result;
400}
401
402
403/*
404 *----------------------------------------------------------------------
405 *
406 * Tol_IncludeCmd --
407 *
408 *       Implements the new Tcl "::tol::include" command.
409 *
410 * Results:
411 *      A standard Tcl result
412 *
413 * Side effects:
414 *      None.
415 *
416 *----------------------------------------------------------------------
417 */
418
419static int
420Tol_IncludeCmd(clientData, interp, objc, objv)
421     ClientData clientData;  /* Not used. */
422     Tcl_Interp *interp;             /* Current interpreter */
423     int objc;                                 /* Number of arguments */
424     Tcl_Obj *CONST objv[];  /* Argument objects */
425{
426  Tcl_Obj * obj_result= Tcl_NewObj();
427  int tcl_result;
428 
429  if (objc != 2) {
430    Tcl_SetStringObj(obj_result,
431                     "wrong # args: should be \"::tol::include tolfile\"",
432                     -1);
433    tcl_result = TCL_ERROR;
434  } else
435    tcl_result = Tol_IncludeFile(interp,objv[1],obj_result);
436  Tcl_SetObjResult(interp,obj_result);
437  return tcl_result;
438}
439
440
441/*
442 *----------------------------------------------------------------------
443 *
444 * Tol_DecompileCmd --
445 *
446 *       Implements the new Tcl "::tol::decompile" command.
447 *
448 * Results:
449 *      A standard Tcl result
450 *
451 * Side effects:
452 *      None.
453 *
454 *----------------------------------------------------------------------
455 */
456
457static int
458Tol_DecompileCmd(clientData, interp, objc, objv)
459     ClientData clientData;  /* Not used. */
460     Tcl_Interp *interp;             /* Current interpreter */
461     int objc;                                 /* Number of arguments */
462     Tcl_Obj *CONST objv[];  /* Argument objects */
463{
464  Tcl_Obj * obj_result= Tcl_NewObj();
465  int tcl_result;
466 
467  if (objc != 2) {
468    Tcl_AppendStringsToObj(obj_result,
469                           "wrong # args: should be \'",
470                           Tcl_GetString(objv[0]), " tolfile\'", NULL);
471    tcl_result = TCL_ERROR;
472  } else
473    tcl_result = Tol_DecompileFile(interp,objv[1],obj_result);
474  Tcl_SetObjResult(interp,obj_result);
475  return tcl_result;
476}
477
478
479/*
480 *----------------------------------------------------------------------
481 *
482 * Tol_ConsoleCmd --
483 *
484 *  Implements the new Tcl "::tol::console" command.
485 *
486 *    ::tol::console eval tol_expr
487 *
488 *        evaluate a tol_expr, if the result has name then it will be
489 *        stored in the console's stack.
490 *
491 *    ::tol::console stack list [obj_name]
492 *
493 *        return the content of obj_name. If no object is given then
494 *        list the set object contained in the stack.
495 *
496 *    ::tol::console stack release [obj_name]
497 *
498 *        release the specified object contained in the console's
499 *        stack. If no object is given then the whole stack is
500 *        released.
501 *
502 * Results:
503 *      A standard Tcl result
504 *
505 * Side effects:
506 *      None.
507 *
508 *----------------------------------------------------------------------
509 */
510
511static int
512Tol_ConsoleCmd(clientData, interp, objc, objv)
513     ClientData clientData;  /* Not used. */
514     Tcl_Interp *interp;             /* Current interpreter */
515     int objc;                                 /* Number of arguments */
516     Tcl_Obj *CONST objv[];  /* Argument objects */
517{
518  Tcl_Obj * obj_result= Tcl_NewObj();
519  int tcl_result;
520 
521  if (objc < 3) {
522    Tcl_AppendStringsToObj(obj_result,
523                           "wrong # args: should be '",
524                           Tcl_GetString(objv[0]), " option arg ?arg?'",NULL);
525    tcl_result = TCL_ERROR;
526  } else {
527    Tcl_DString dstr;
528    Tcl_DStringInit(&dstr);
529    Tcl_UtfToExternalDString(NULL,Tcl_GetString(objv[1]),-1,&dstr);
530    if (!strncmp(dstr.string,"eval",dstr.length)) {
531      if (objc != 3 && objc != 4) {
532        Tcl_AppendStringsToObj(obj_result,
533                               "wrong # args: should be '",
534                               Tcl_GetString(objv[0]),
535                               " eval ?-hidden? tol_expr'",NULL);
536        tcl_result = TCL_ERROR;
537      } else {
538        Tcl_Obj *obj_expr = NULL;
539        int hidden = 0;
540
541        if (objc==4) {
542          if (strcmp(Tcl_GetString(objv[2]),"-hidden")) {
543            Tcl_AppendStringsToObj(obj_result,
544                                   "invalid option ",
545                                   Tcl_GetString(objv[2]),
546                                   ": should be -hidden",
547                                   NULL);
548            tcl_result = TCL_ERROR;
549          } else {
550            hidden = 1;
551            obj_expr = objv[3];
552          }
553        } else {
554          obj_expr = objv[2];
555        }
556        if (obj_expr) {
557          tcl_result = Tol_EvalExpr(obj_expr, hidden, obj_result);
558        }
559      }
560      Tcl_DStringFree(&dstr);
561    } else if (!strncmp(dstr.string,"stack",dstr.length)) {
562      Tcl_DStringFree(&dstr);
563      Tcl_UtfToExternalDString(NULL,Tcl_GetString(objv[2]),-1,&dstr);
564      if (!strncmp(dstr.string,"list",dstr.length))
565        tcl_result = Tol_ListStack(interp,objc-3,objv+3,obj_result);
566      else if (!strncmp(dstr.string,"release",dstr.length))
567        tcl_result = Tol_ReleaseStack(interp,objc-3,objv+3,obj_result);
568      else {
569        Tcl_AppendStringsToObj(obj_result,
570                               "invalid option '",
571                               Tcl_GetString(objv[2]),
572                               "', should be: list or release",NULL);
573        tcl_result = TCL_ERROR;
574      }
575      Tcl_DStringFree(&dstr);
576    } else {
577      Tcl_AppendStringsToObj(obj_result,
578                             "invalid option '",
579                             Tcl_GetString(objv[1]),
580                             "', should be: eval or stack",NULL);
581      tcl_result = TCL_ERROR;
582      Tcl_DStringFree(&dstr);
583    }
584  }
585  Tcl_SetObjResult(interp,obj_result);
586  return tcl_result;
587}
588
589
590/*
591 *----------------------------------------------------------------------
592 *
593 * Tol_ForAllChildCmd --
594 *
595 *        Implements the new Tcl "::tol::forallchild" command.
596 *
597 *  ::tol::forallchild setName ?indexes? script
598 *
599 * Results:
600 *       A standard Tcl result
601 *
602 * Side effects:
603 *       None.
604 *
605 *----------------------------------------------------------------------
606 */
607
608static int
609Tol_ForAllChildCmd(clientData, interp, objc, objv)
610     ClientData clientData;  /* Not used. */
611     Tcl_Interp *interp;             /* Current interpreter */
612     int objc;                                 /* Number of arguments */
613     Tcl_Obj *CONST objv[];  /* Argument objects */
614{
615  Tcl_Obj * obj_result= Tcl_NewObj();
616  int tcl_result;
617 
618  if (objc != 3) {
619    Tcl_AppendStringsToObj(obj_result, "wrong # args: should be '",
620                           Tcl_GetString(objv[0]), " setref script'", NULL);
621    tcl_result = TCL_ERROR;
622  } else
623    tcl_result = Tol_IterChildren(interp,objc-1,objv+1,obj_result);
624  Tcl_SetObjResult( interp, obj_result );
625  return tcl_result;
626}
627
628
629/*
630 *----------------------------------------------------------------------
631 *
632 * Tol_ForEachCmd --
633 *
634 *        Implements the new Tcl "::tol::foreach" command.
635 *
636 *  ::tol::foreach varname <Set or NameBlock reference> script
637 *
638 * Results:
639 *       A standard Tcl result
640 *
641 * Side effects:
642 *       None.
643 *
644 *----------------------------------------------------------------------
645 */
646
647static int
648Tol_ForEachCmd(clientData, interp, objc, objv)
649     ClientData clientData;  /* Not used. */
650     Tcl_Interp *interp;             /* Current interpreter */
651     int objc;                                 /* Number of arguments */
652     Tcl_Obj *CONST objv[];  /* Argument objects */
653{
654  Tcl_Obj * obj_result= Tcl_NewObj();
655  int tcl_result;
656 
657  if (objc != 4) {
658    Tcl_AppendStringsToObj(obj_result, "wrong # args: should be '",
659                           Tcl_GetString(objv[0]),
660                           " varName setref script'", NULL);
661    tcl_result = TCL_ERROR;
662  } else
663    tcl_result = Tol_ForEach( interp, objc - 1, objv + 1, obj_result );
664  Tcl_SetObjResult( interp, obj_result );
665  return tcl_result;
666}
667
668
669/*
670 *----------------------------------------------------------------------
671 *
672 * Tol_GetSerie --
673 *
674 *        Implements the new Tcl "::tol::getserie" command.
675 *
676 * Results:
677 *       A standard Tcl result
678 *
679 * Side effects:
680 *       None.
681 *
682 *----------------------------------------------------------------------
683 */
684
685static int
686Tol_GetSerieCmd(clientData, interp, objc, objv)
687     ClientData clientData;  /* Not used. */
688     Tcl_Interp *interp;             /* Current interpreter */
689     int objc;                                 /* Number of arguments */
690     Tcl_Obj *CONST objv[];  /* Argument objects */
691{
692  Tcl_Obj * obj_result= Tcl_NewObj();
693  int tcl_result;
694 
695  if (objc < 2 || objc > 4) {
696    Tcl_AppendStringsToObj(obj_result,
697                           "wrong # args: should be '",
698                           Tcl_GetString(objv[0]),
699                           " sername ?begin end?'", NULL );
700    tcl_result = TCL_ERROR;
701  } else
702    tcl_result = Tol_GetSerieContent(interp,objc-1,objv+1,obj_result);
703  Tcl_SetObjResult(interp,obj_result);
704  return tcl_result;
705}
706
707/*
708 *----------------------------------------------------------------------
709 *
710 * Tol_TableCmd --
711 *
712 *     Implements the new Tcl "::tol::tableset" command.
713 *     Is an internal interface to the commands tol::tableset
714 *     & tol::tablematrix.
715 *
716 * Results:
717 *       A standard Tcl result
718 *
719 * Side effects:
720 *       None.
721 *
722 *----------------------------------------------------------------------
723 */
724
725static int
726Tol_TableCmd(ismat, clientData, interp, objc, objv)
727  int ismat;
728  ClientData clientData;  /* Not used. */
729  Tcl_Interp *interp;     /* Current interpreter */
730  int objc;               /* Number of arguments */
731  Tcl_Obj *CONST objv[];  /* Argument objects */
732{
733  Tcl_Obj * obj_result= Tcl_NewObj();
734  int tcl_result;
735 
736  if ( objc < 3 ) {
737    Tcl_AppendStringsToObj(obj_result,
738                           "wrong # args: should be '",
739                           Tcl_GetString(objv[0]),
740                           " option arg ?arg?'", NULL );
741    tcl_result = TCL_ERROR;
742  } else {
743    char * option = Tcl_GetString(objv[1]);
744    int length = strlen(option);
745    if (!strncmp("create",option,length)) {
746      if ( objc < 4 ) {
747        Tcl_AppendStringsToObj(obj_result,
748                               "wrong # args: should be '",
749                               Tcl_GetString(objv[0]),
750                               " create tblName (set|matrix)'", NULL );
751        tcl_result = TCL_ERROR;
752      } else {     
753        tcl_result = Tol_CreateTable(interp,objv[2],objv[3], ismat, obj_result);
754        if (tcl_result == TCL_ERROR)
755          Tcl_AppendStringsToObj(obj_result,
756                                 ": could not create '",
757                                 Tcl_GetString(objv[2]),"'",NULL);
758      }
759    } else if (!strncmp("destroy",option,length))
760      if ( objc < 3) {
761        Tcl_AppendStringsToObj(obj_result,
762                               "wrong # args: should be '",
763                               Tcl_GetString(objv[0]),
764                               " destroy tblName ?args?'", NULL );
765        tcl_result = TCL_ERROR;
766      } else {
767        tcl_result = Tol_DestroyTable( interp, objc-2, objv+2, obj_result);
768      }
769    else {
770      Tcl_AppendStringsToObj(obj_result,
771                             "bad option '",
772                             option, "': must be create or destroy", NULL);
773      tcl_result = TCL_ERROR;
774    }
775  }
776
777  Tcl_SetObjResult(interp,obj_result);
778  return tcl_result;
779}
780
781/*
782 *----------------------------------------------------------------------
783 *
784 * Tol_TableSetCmd --
785 *
786 *     Implements the new Tcl "::tol::tableset" command.
787 * 
788 *     ::tol::tableset option arg ?arg?
789 *
790 *     ::tol::tableset ?create? tblName setReference
791 *
792 *     ::tol::tableset destroy tblName ?grpname ...?
793 *
794 * Results:
795 *       A standard Tcl result
796 *
797 * Side effects:
798 *       None.
799 *
800 *----------------------------------------------------------------------
801 */
802
803static int
804Tol_TableSetCmd(clientData, interp, objc, objv)
805  ClientData clientData;  /* Not used. */
806  Tcl_Interp *interp;     /* Current interpreter */
807  int objc;               /* Number of arguments */
808  Tcl_Obj *CONST objv[];  /* Argument objects */
809{
810  return Tol_TableCmd(0, clientData, interp, objc, objv);
811}
812
813/*
814 *----------------------------------------------------------------------
815 *
816 * Tol_TableMatCmd --
817 *
818 *     Implements the new Tcl "::tol::tablematrix" command.
819 * 
820 *     ::tol::tablematrix option arg ?arg?
821 *
822 *     ::tol::tablematrix ?create? tblName setReference
823 *
824 *     ::tol::tablematrix destroy tblName ?grpname ...?
825 *
826 * Results:
827 *       A standard Tcl result
828 *
829 * Side effects:
830 *       None.
831 *
832 *----------------------------------------------------------------------
833 */
834
835static int
836Tol_TableMatCmd(clientData, interp, objc, objv)
837  ClientData clientData;  /* Not used. */
838  Tcl_Interp *interp;     /* Current interpreter */
839  int objc;               /* Number of arguments */
840  Tcl_Obj *CONST objv[];  /* Argument objects */
841{
842  return Tol_TableCmd(1, clientData, interp, objc, objv);
843}
844
845/*
846 *----------------------------------------------------------------------
847 *
848 * Tol_SerieGrpCmd --
849 *
850 *     Implements the new Tcl "::tol::seriegrp" command.
851 * 
852 *     ::tol:seriegrp option arg ?arg?
853 *
854 *     ::tol::seriegrp ?create? grpName ?range? serName ?serName?
855 *
856 *     ::tol::seriegrp destroy grpName ?grpName?
857 *
858 * Results:
859 *       A standard Tcl result
860 *
861 * Side effects:
862 *       None.
863 *
864 *----------------------------------------------------------------------
865 */
866
867static int
868Tol_SerieGrpCmd(clientData, interp, objc, objv)
869     ClientData clientData;  /* Not used. */
870     Tcl_Interp *interp;             /* Current interpreter */
871     int objc;                       /* Number of arguments */
872     Tcl_Obj *CONST objv[];  /* Argument objects */
873{
874  Tcl_Obj * obj_result= Tcl_NewObj();
875  int tcl_result;
876 
877  if ( objc < 3 ) {
878    Tcl_AppendStringsToObj(obj_result,
879                           "wrong # args: should be '",
880                           Tcl_GetString(objv[0]), " option arg ?arg?'", NULL );
881    tcl_result = TCL_ERROR;
882  } else {
883    char * option = Tcl_GetString(objv[1]);
884    int length = strlen(option);
885    if (!strncmp("create",option,length)) {
886      if ( objc == 3 ) {
887        Tcl_AppendStringsToObj(obj_result,
888                               "wrong # args: should be '",
889                               Tcl_GetString(objv[0]),
890                               " create grpName ?-range range? serName ?serName?'", NULL );
891        tcl_result = TCL_ERROR;
892      } else {
893        tcl_result = Tol_CreateSerieGrp(interp,objc-2,objv+2,obj_result);
894        if (tcl_result == TCL_ERROR)
895          Tcl_AppendStringsToObj(obj_result,
896                                 ": could not create '",
897                                 Tcl_GetString(objv[2]),"'",NULL);
898      }
899    } else if (!strncmp("destroy",option,length))
900      tcl_result = Tol_DestroySerieGrp(interp,objc-2,objv+2,obj_result);
901    else {
902      Tcl_AppendStringsToObj(obj_result,
903                             "bad option '",
904                             option, "': must be create or destroy", NULL);
905      tcl_result = TCL_ERROR;
906    }
907  }
908
909  Tcl_SetObjResult(interp,obj_result);
910  return tcl_result;
911}
912
913
914/*
915 *----------------------------------------------------------------------
916 *
917 * Tol_LanguageCmd --
918 *
919 *        Implements the new Tcl "::tol::language" command.
920 *
921 *          ::tol::language ?lang?
922 *
923 * Results:
924 *
925 *       Set or return the language, as required by TOL only english
926 *       or spanish.
927 *
928 *       A standard Tcl result
929 *
930 * Side effects:
931 *       None.
932 *
933 *----------------------------------------------------------------------
934 */
935
936static int
937Tol_LanguageCmd(clientData, interp, objc, objv)
938     ClientData clientData;  /* Not used. */
939     Tcl_Interp *interp;     /* Current interpreter */
940     int objc;               /* Number of arguments */
941     Tcl_Obj *CONST objv[];  /* Argument objects */
942{
943  Tcl_Obj * obj_result = Tcl_NewObj();
944  int tcl_result;
945
946  if ( objc > 2 ) {
947    Tcl_AppendStringsToObj(obj_result,"wrong # args: should be '",
948                           Tcl_GetString(objv[0]),
949                           " ?lang?'", NULL);
950    tcl_result = TCL_ERROR;
951  } else {
952    if ( objc == 2 )
953      tcl_result = Tol_SetLanguage( interp, objv[1], obj_result );
954    else
955      tcl_result = Tol_GetLanguage( interp, obj_result );
956  }
957  Tcl_SetObjResult(interp,obj_result);
958  return tcl_result;
959}
960
961
962/*
963 *----------------------------------------------------------------------
964 *
965 * Tol_InfoCmd --
966 *
967 *        Implements the new Tcl "::tol::info" command.
968 *
969 * Results:
970 *       A standard Tcl result
971 *
972 * Side effects:
973 *       None.
974 *
975 *----------------------------------------------------------------------
976 */
977
978static int
979Tol_InfoCmd(clientData, interp, objc, objv)
980     ClientData clientData;  /* Not used. */
981     Tcl_Interp *interp;             /* Current interpreter */
982     int objc;                                 /* Number of arguments */
983     Tcl_Obj *CONST objv[];  /* Argument objects */
984{
985  Tcl_Obj * obj_result = Tcl_NewObj();
986  int tcl_result;
987  char * arg;
988  int length;
989 
990  if ( objc == 1) {
991    Tcl_AppendStringsToObj( obj_result, "wrong # args: should be '",
992                      Tcl_GetString(objv[0]),
993                      " ?arg arg ...?'", NULL );
994    tcl_result = TCL_ERROR;
995  } else {
996    arg = Tcl_GetString(objv[1]);
997    length = strlen(arg);
998    if ( !strncasecmp("version", arg, length)) {
999      if ( objc == 2 )
1000        tcl_result = Tol_InfoVersion(interp, obj_result);
1001      else {
1002        Tcl_AppendStringsToObj(obj_result,
1003                               "wrong # args: should be '",
1004                               Tcl_GetString(objv[0])," version'",
1005                               NULL);
1006        tcl_result = TCL_ERROR;
1007      }
1008    } else if (!strncasecmp("reference", arg, length)) {
1009      /* if (objc > 4 || objc < 3) { */
1010      if (objc != 3) {
1011        Tcl_AppendStringsToObj(obj_result,
1012                               "wrong # args: should be '",
1013                               Tcl_GetString(objv[0]),
1014                               " reference {grammar|container objname ?indexes?}'",
1015                               NULL);
1016        tcl_result = TCL_ERROR;
1017      } else
1018        tcl_result = Tol_GetReference(interp, objc-2, objv+2, obj_result);
1019    } else if (!strncasecmp("address", arg, length)) {
1020      if (objc != 3) {
1021        Tcl_AppendStringsToObj(obj_result,
1022                               "wrong # args: should be '",
1023                               Tcl_GetString(objv[0]),
1024                               " address {grammar|container objname ?indexes?}'",
1025                               NULL);
1026        tcl_result = TCL_ERROR;
1027      } else {
1028        tcl_result = Tol_GetAddressFromObject( interp,
1029                                              objv[2], obj_result );
1030      }
1031    } else if (!strncasecmp("anything", arg, length)) {
1032      if (objc != 3) {
1033        Tcl_AppendStringsToObj(obj_result,
1034                               "wrong # args: should be '",
1035                               Tcl_GetString(objv[0]),
1036                               " anything {grammar|container objname ?indexes?}'",
1037                               NULL);
1038        tcl_result = TCL_ERROR;
1039      } else {
1040        tcl_result = Tol_GetAnythingType( interp,
1041                                          objv[2], obj_result );
1042      }
1043    } else if (!strncasecmp("included", arg, length)) {
1044      if (objc == 2)
1045        tcl_result = Tol_InfoIncluded(interp, obj_result);
1046      else if (objc == 3)
1047        tcl_result = Tol_InfoFile(interp,objv[2],obj_result);
1048      else {
1049        Tcl_AppendStringsToObj(obj_result,"wrong # args: should be '",
1050                               Tcl_GetString(objv[0]), " include'", NULL);
1051        tcl_result = TCL_ERROR;
1052      }
1053    } else if (!strncasecmp("functions", arg, length))
1054      tcl_result = Tol_InfoFunctions(interp, objc-1, objv+1, obj_result);
1055    else if (!strncasecmp("grammars", arg, length))
1056      tcl_result = Tol_InfoGrammars(interp, objc-1, objv+1, obj_result);
1057    else if (!strncasecmp("packages", arg, length))
1058      tcl_result = Tol_InfoPackages(interp, objc-1, objv+1, obj_result);
1059    else if (!strncasecmp("variables", arg, length))
1060      tcl_result = Tol_InfoVariables(interp, objc-1, objv+1, obj_result);
1061    else if (!strncasecmp("struct", arg, length))
1062      tcl_result = Tol_InfoStruct(interp, objc-1, objv+1, obj_result);
1063    else if (!strncasecmp("path", arg, length))
1064      tcl_result = Tol_InfoPath(interp, objc-1, objv+1, obj_result);
1065    else {
1066      Tcl_SetStringObj( obj_result, "bad option '", -1);
1067      Tcl_AppendStringsToObj( obj_result, Tcl_GetString( objv[1] ),
1068                              "' : must be included, functions, grammars, variables, struct, path or version", NULL );
1069      tcl_result = TCL_ERROR;
1070    }
1071  }
1072  Tcl_SetObjResult(interp,obj_result);
1073  return tcl_result;
1074}
1075
1076
1077/*
1078 *----------------------------------------------------------------------
1079 *
1080 * Tol_InfoStruct --
1081 *
1082 *        Implements the new Tcl "::tol::info struct" subcommand.
1083 *
1084 *  ::tol::info struct ?name?
1085 *
1086 * Results:
1087 *       A standard Tcl result
1088 *
1089 * Side effects:
1090 *       None.
1091 *
1092 *----------------------------------------------------------------------
1093 */
1094
1095static int Tol_InfoStruct(interp, objc, objv, obj_result)
1096     Tcl_Interp *interp;             /* Current interpreter */
1097     int objc;                       /* Number of arguments */
1098     Tcl_Obj *CONST objv[];          /* Argument objects */
1099     Tcl_Obj * obj_result;           /* subcommand's result */
1100{
1101  if ( objc > 2 ) {
1102    Tcl_AppendStringsToObj( obj_result, "wrong # args: should be '",
1103                      Tcl_GetString(objv[0]),
1104                      " struct ?struct-name?'", NULL);
1105    return TCL_ERROR;
1106  }
1107  if ( objc == 1 ) {
1108    Tcl_AppendStringsToObj(obj_result, "wrong # args: '",
1109                           Tcl_GetString(objv[0]),
1110                           " struct\' not implemented yet",
1111                           NULL);
1112    return TCL_ERROR;
1113  }
1114  return Tol_GetStructure( interp, objv[1], obj_result );
1115/*  return  objc == 1 ? Tol_GetAllStructures( interp, obj_result ) :
1116    Tol_GetStructure( interp, objv[1], obj_result ); */
1117}
1118
1119
1120/*
1121 *----------------------------------------------------------------------
1122 *
1123 * Tol_InfoPath --
1124 *
1125 *        Implements the new Tcl "::tol::info path" subcommand.
1126 *
1127 *  ::tol::info path set-reference
1128 *
1129 * Results:
1130 *       A standard Tcl result
1131 *
1132 * Side effects:
1133 *       None.
1134 *
1135 *----------------------------------------------------------------------
1136 */
1137
1138static int Tol_InfoPath(interp, objc, objv, obj_result)
1139     Tcl_Interp *interp;             /* Current interpreter */
1140     int objc;                       /* Number of arguments */
1141     Tcl_Obj *CONST objv[];          /* Argument objects */
1142     Tcl_Obj * obj_result;           /* subcommand's result */
1143{
1144  if ( objc != 2 ) {
1145    Tcl_AppendStringsToObj(obj_result,
1146                           "wrong # args: should be '",
1147                           Tcl_GetString(objv[0]),
1148                           " path set'", NULL);
1149    return TCL_ERROR;
1150  }
1151  return Tol_GetSetPath(interp, objv[1], obj_result);
1152}
1153
1154
1155/*
1156 *----------------------------------------------------------------------
1157 *
1158 * Tol_InfoFunctions --
1159 *
1160 *        Implements the subcommand "::tol::info functions ?function?".
1161 *
1162 * Results:
1163 *       A standard Tcl result
1164 *
1165 * Side effects:
1166 *       None.
1167 *
1168 *----------------------------------------------------------------------
1169 */
1170
1171static int
1172Tol_InfoFunctions(interp, objc, objv, obj_result)
1173     Tcl_Interp *interp;             /* Current interpreter */
1174     int objc;                                 /* Number of arguments */
1175     Tcl_Obj *CONST objv[];  /* Argument objects */
1176     Tcl_Obj * obj_result;   /* subcommand's result */
1177{
1178  if ( objc < 2 || objc > 3 ) {
1179    Tcl_AppendStringsToObj(obj_result,
1180                           "wrong # args: should be '",
1181                           Tcl_GetString(objv[0]),
1182                           " functions graname ?funname?'", NULL);
1183    return TCL_ERROR;
1184  }
1185  return  objc == 2 ? Tol_SetFunctionsObj(interp, objv[1], obj_result) :
1186    Tol_SetFunctionInfoObj(objv[1], objv[2], obj_result);
1187}
1188
1189
1190/*
1191 *----------------------------------------------------------------------
1192 *
1193 * Tol_InfoGrammars --
1194 *
1195 *        Implements the subcommand "::tol::info grammars ?grammar?".
1196 *
1197 * Results:
1198 *       A standard Tcl result
1199 *
1200 * Side effects:
1201 *       None.
1202 *
1203 *----------------------------------------------------------------------
1204 */
1205
1206static int
1207Tol_InfoGrammars(interp, objc, objv, obj_result)
1208     Tcl_Interp *interp;             /* Current interpreter */
1209     int objc;                                 /* Number of arguments */
1210     Tcl_Obj *CONST objv[];  /* Argument objects */
1211     Tcl_Obj * obj_result;
1212{
1213  if ( objc > 2 ) {
1214    Tcl_AppendStringsToObj(obj_result,
1215                           "wrong # args: should be '",
1216                           Tcl_GetString(objv[0]), " grammars ?graname?'",
1217                           NULL);
1218    return TCL_ERROR;
1219  }
1220  return  objc == 1 ? Tol_SetGrammarsObj(interp, obj_result) :
1221    Tol_SetGrammarDescObj(interp, objv[1], obj_result);
1222}
1223
1224
1225/*
1226 *----------------------------------------------------------------------
1227 *
1228 * Tol_InfoGrammars --
1229 *
1230 *        Implements the subcommand "::tol::info grammars ?grammar?".
1231 *
1232 * Results:
1233 *       A standard Tcl result
1234 *
1235 * Side effects:
1236 *       None.
1237 *
1238 *----------------------------------------------------------------------
1239 */
1240
1241static int
1242Tol_InfoPackages(interp, objc, objv, obj_result)
1243     Tcl_Interp *interp;       /* Current interpreter */
1244     int objc;                 /* Number of arguments */
1245     Tcl_Obj *CONST objv[];    /* Argument objects */
1246     Tcl_Obj * obj_result;
1247{
1248  if ( objc > 2 ) {
1249    Tcl_AppendStringsToObj(obj_result,
1250                           "wrong # args: should be '",
1251                           Tcl_GetString(objv[0]), " packages ?pkgName?'",
1252                           NULL);
1253    return TCL_ERROR;
1254  }
1255  return  objc == 1 ? Tol_SetPackagesObj(interp, obj_result) :
1256    Tol_SetPackageDescObj(interp, objv[1], obj_result);
1257}
1258
1259
1260/*
1261 *----------------------------------------------------------------------
1262 *
1263 * Tol_InfoVariables --
1264 *
1265 *        Implements the new Tcl "::tol::info variables" command.
1266 *
1267 * Results:
1268 *       A standard Tcl result
1269 *
1270 * Side effects:
1271 *       None.
1272 *
1273 *----------------------------------------------------------------------
1274 */
1275
1276static int
1277Tol_InfoVariables(interp, objc, objv, obj_result)
1278Tcl_Interp *interp;             /* Current interpreter */
1279     int objc;                                 /* Number of arguments */
1280     Tcl_Obj *CONST objv[];  /* Argument objects */
1281     Tcl_Obj * obj_result;
1282{
1283  if ( objc != 2 ) {
1284    Tcl_AppendStringsToObj(obj_result,
1285                     "wrong # args: should be '",
1286                     Tcl_GetString(objv[0]),
1287                     " {grammar|container ?objname? ?indexes?}",
1288                     NULL);
1289    return TCL_ERROR;
1290  }
1291  return  Tol_SetVariablesObj(interp, objv[1], obj_result);
1292}
1293
1294
1295/*
1296 *----------------------------------------------------------------------
1297 *
1298 * Tol_GetMatrixCmd --
1299 *
1300 *        Implements the new Tcl "::tol::matrix" command.
1301 *
1302 * Results:
1303 *       {matname rows colums {<data>}}
1304 *
1305 * Side effects:
1306 *       None.
1307 *
1308 *----------------------------------------------------------------------
1309 */
1310
1311static int
1312Tol_GetMatrixCmd(ClientData  clientData, /* Not used. */
1313                 Tcl_Interp *interp,     /* Current interpreter */
1314                 int objc,               /* Number of arguments */
1315                 Tcl_Obj *CONST objv[])  /* Argument objects */
1316{
1317  Tcl_Obj * obj_result = Tcl_NewObj();
1318  int tcl_result;
1319
1320  if ( objc != 2) {
1321    Tcl_AppendStringsToObj(obj_result,
1322                           "wrong # args: should be '",
1323                            Tcl_GetString(objv[0]),
1324                            " matrix\"", NULL );
1325    tcl_result = TCL_ERROR;
1326  } else {
1327    tcl_result = Tol_GetMatrixContent(interp,objv[1],obj_result);
1328  }
1329  Tcl_SetObjResult(interp,obj_result);
1330  return tcl_result;
1331}
1332
1333
1334/*
1335 *----------------------------------------------------------------------
1336 *
1337 * Tol_TimeSetCmd --
1338 *
1339 *        Implements the new Tcl "::tol::timeset" command.
1340 *
1341 *       tol::timeset create tms toltms
1342 *       tol::timeset destroy tms ?tms?
1343 *
1344 *       tms start date
1345 *       tms get
1346 *       tms next
1347 *       tms previous
1348 *
1349 * Results:
1350 *       the new tms command
1351 *
1352 * Side effects:
1353 *       None.
1354 *
1355 *----------------------------------------------------------------------
1356 */
1357
1358int Tol_TimeSetCmd ( ClientData clientData, Tcl_Interp *interp,
1359                     int objc, Tcl_Obj *CONST objv[] )
1360{
1361  Tcl_Obj * obj_result = Tcl_NewObj();
1362  int tcl_result;
1363
1364  char * cmdname = Tcl_GetString(objv[0]);
1365
1366  if ( objc < 3 ) {
1367    Tcl_AppendStringsToObj(obj_result,
1368                           "wrong # args: should be '",
1369                           cmdname,
1370                           " option arg ?arg?'", NULL );
1371    tcl_result = TCL_ERROR;
1372  } else {
1373    char * option = Tcl_GetString(objv[1]);
1374    int optlen = strlen(option);
1375
1376    if ( !strncmp(option, "create", optlen) ) {
1377      if ( objc != 4 ) {
1378        Tcl_AppendStringsToObj( obj_result, "wrong # args: should be '",
1379                                cmdname, " ", option,
1380                                " tms toltms'", NULL );
1381        tcl_result = TCL_ERROR;
1382      } else
1383        tcl_result = Tol_CreateTMSCmd( interp, objv[2], objv[3], obj_result );
1384    }
1385    else if ( !strncmp(option, "destroy", optlen) )
1386      tcl_result = Tol_DestroyTMSCmd( interp, objc-2, objv+2, obj_result );
1387    else {
1388      Tcl_AppendStringsToObj(obj_result, "invalid option name '", option,
1389                              "', should be: create or destroy", NULL);
1390      tcl_result = TCL_ERROR;
1391    }
1392  }
1393
1394  Tcl_SetObjResult(interp,obj_result);
1395  return tcl_result;
1396}
1397
1398
1399/*
1400 *----------------------------------------------------------------------
1401 *
1402 * Tol_DateCmd --
1403 *
1404 *        Implements the new Tcl "::tol::date" command.
1405 *
1406 *       tol::date first              -> default first date
1407 *       tol::date last               -> default last  date
1408 *       tol::date now     ?fmt?      -> today date & time
1409 *       tol::date weekday date       -> 0(sunday), 1(monday), ..., 6(saturday)
1410 *       tol::date days    year month -> number of days of month/year
1411 *       tol::date +day    date ?n?   -> date ++ ?n days?
1412 *       tol::date +month  date ?n?   -> date ++ ?n months?
1413 *
1414 * Results:
1415 *       a valid date
1416 *
1417 * Side effects:
1418 *       None.
1419 *
1420 *----------------------------------------------------------------------
1421 */
1422
1423static int Tol_DateCmd ( ClientData clientData, Tcl_Interp *interp,
1424                         int objc, Tcl_Obj *CONST objv[] )
1425{
1426  Tcl_Obj * obj_result = Tcl_NewObj();
1427  int tcl_result;
1428
1429  if ( objc < 2 || objc > 4 ) {
1430    char * cmdname = Tcl_GetString(objv[0]);
1431    Tcl_AppendStringsToObj(obj_result, "wrong # args: should be \n",
1432                           cmdname, " first,\n",
1433                           cmdname, " last,\n",
1434                           cmdname, " now ?fmt?,\n",
1435                           cmdname, " weekday,\n",
1436                           cmdname, " days year month,\n",
1437                           cmdname, " +day date ?n?, or\n",
1438                           cmdname, " +month date ?n?", NULL);
1439    tcl_result = TCL_ERROR;
1440  } else
1441    tcl_result = Tol_DateOption(interp, objc, objv, obj_result);
1442
1443  Tcl_SetObjResult(interp,obj_result);
1444  return tcl_result;
1445}
1446
1447
1448/*
1449 *----------------------------------------------------------------------
1450 *
1451 * Tol_AutoCorCmd --
1452 *
1453 *        Implements the new Tcl "::tol::autocor" command.
1454 *
1455 *       tol::autocor type serie ?lagsize?
1456 *
1457 * Results:
1458 *       {sername sigma size {data of autocorrelation}}
1459 *
1460 * Side effects:
1461 *       None.
1462 *
1463 *----------------------------------------------------------------------
1464 */
1465
1466static int Tol_AutoCorrCmd (ClientData clientData, Tcl_Interp *interp,
1467                            int objc, Tcl_Obj *CONST objv[])
1468{
1469  Tcl_Obj * obj_result = Tcl_NewObj();
1470  int tcl_result;
1471
1472
1473  if ( objc < 3 || objc > 4 ) {
1474    Tcl_AppendStringsToObj( obj_result, "wrong # args: should be '",
1475                           Tcl_GetString(objv[0]),
1476                           " type serie ?lagsize?'", NULL );
1477    tcl_result = TCL_ERROR;
1478  } else
1479    tcl_result = Tol_GetAutoCorr( interp, objc-1, objv+1,
1480                                  obj_result );
1481
1482  Tcl_SetObjResult(interp,obj_result);
1483  return tcl_result;
1484}
1485
1486
1487/*
1488 *----------------------------------------------------------------------
1489 *
1490 * Tol_SerieStatCmd --
1491 *
1492 *       Implements the new Tcl "::tol::seriestat" command.
1493 *
1494 *       tol::seriestat serieref     
1495 *           -> {serie-name {list of stats names & values}}
1496 *
1497 *       tol::seriestat serieref statname ?args?
1498 *            -> return the stat value. (not implemented yet)
1499 *
1500 * Results:
1501 *       
1502 *
1503 * Side effects:
1504 *       None.
1505 *
1506 *----------------------------------------------------------------------
1507 */
1508
1509static
1510int Tol_SerieStatCmd ( ClientData clientData, Tcl_Interp *interp,
1511                       int objc, Tcl_Obj *CONST objv[] )
1512{
1513  Tcl_Obj * obj_result = Tcl_NewObj();
1514  int tcl_result;
1515
1516  if ( objc < 2 ) {
1517    Tcl_AppendStringsToObj( obj_result, "wrong # args: should be '",
1518                           Tcl_GetString(objv[0]),
1519                           " serieref ?statname ?args??'", NULL );
1520    tcl_result = TCL_ERROR;
1521  } else
1522    tcl_result = Tol_ComputeSerieStat(interp,objc-1,objv+1,obj_result);
1523
1524  Tcl_SetObjResult(interp,obj_result);
1525  return tcl_result;
1526}
1527
1528/*
1529 * Tol_StopEvalCmd --
1530 *
1531 * Implement the command tol::stop which try to stop the current evaluation
1532 * flow inside Evaluate.
1533 *
1534 */
1535static
1536int Tol_StopEvalCmd (ClientData clientData, Tcl_Interp *interp,
1537                     int objc, Tcl_Obj *CONST objv[])
1538{
1539  if ( objc != 1 ) {
1540    Tcl_AppendResult(interp, "wrong # args: should be '",
1541                     Tcl_GetString(objv[0]),  "'", NULL);
1542    return TCL_ERROR;
1543  }
1544  return Tol_StopEvaluation();
1545}
1546
1547/*
1548 * Tol_LCFormatCmd --
1549 *
1550 * Implement the command tol::lc_format which format a double given
1551 * the format of reals inside TOL.
1552 *
1553 */
1554static
1555int Tol_LCFormatCmd (ClientData clientData, Tcl_Interp *interp,
1556                     int objc, Tcl_Obj *CONST objv[])
1557{
1558  Tcl_Obj * obj_result;
1559  int tcl_result;
1560
1561  if ( objc != 2 ) {
1562    Tcl_AppendResult( interp, "wrong # args: should be '",
1563                      Tcl_GetString(objv[0]),  " double_value'",
1564                      NULL );
1565    tcl_result = TCL_ERROR;
1566  } else {
1567    obj_result = Tcl_NewObj();
1568    tcl_result = Tol_LCFormat(interp,objv[1],obj_result);
1569    Tcl_SetObjResult(interp, obj_result);
1570  }
1571  return tcl_result;
1572}
1573
1574
1575/*
1576 *----------------------------------------------------------------------
1577 *
1578 * Toltcl_Init --
1579 *
1580 *       Initialize the new package.  The string "Toltcl" in the
1581 *       function name must match the PACKAGE declaration at the top of
1582 *       configure.in.
1583 *
1584 * Results:
1585 *       A standard Tcl result
1586 *
1587 * Side effects:
1588 *       The TolTcl package is created.
1589 *      The commands: ::tol::grammars
1590 *
1591 *----------------------------------------------------------------------
1592 */
1593
1594int
1595Toltcl_Init(Tcl_Interp *interp)
1596{
1597  /* Inicializo la captura de segfault */
1598
1599  InitCrashHandler();
1600 
1601  TT_interp = interp;
1602
1603  if (Tcl_InitStubs(interp, "8.3", 0) == NULL) {
1604    return TCL_ERROR;
1605  }
1606  if (Tcl_PkgRequire(interp, "Tcl", "8.3", 0) == NULL) {
1607    return TCL_ERROR;
1608  }
1609  if (Tcl_PkgProvide(interp, "Toltcl", TOLTCL_VERSION) != TCL_OK) {
1610    return TCL_ERROR;
1611  }
1612 
1613  /*
1614   *  Create the commands
1615   *
1616   */
1617 
1618  Tcl_CreateObjCommand( interp, "::tol::initkernel", Tol_InitKernelCmd,
1619                        (ClientData)NULL, (Tcl_CmdDeleteProc *)NULL );
1620 
1621  /*
1622   *  Inititialize TOL
1623   *
1624   */
1625 
1626  if ( !TOLHasBeenInitialized( ) ) {
1627    Tol_InstallHciWriter();
1628  }
1629  Tol_InstallMethodsHook();
1630 
1631  return TCL_OK;
1632}
1633
1634#ifdef __WIN32__
1635#ifndef STATIC_BUILD
1636
1637#include <windows.h>
1638
1639/*
1640 * The following declaration is for the VC++ DLL entry point.
1641 */
1642
1643BOOL APIENTRY           DllMain(HINSTANCE hInst, DWORD reason,
1644                                LPVOID reserved);
1645/*
1646 *----------------------------------------------------------------------
1647 *
1648 * DllMain --
1649 *
1650 *      This routine is called by the VC++ C run time library init
1651 *      code, or the DllEntryPoint routine.
1652 *
1653 * Results:
1654 *      TRUE on sucess, FALSE on failure.
1655 *
1656 * Side effects:
1657 *
1658 *----------------------------------------------------------------------
1659 */
1660
1661BOOL APIENTRY
1662DllMain(hInst, reason, reserved)
1663     HINSTANCE hInst;    /* Library instance handle. */
1664     DWORD reason;       /* Reason this function is being called. */
1665     LPVOID reserved;    /* Not used. */
1666{
1667  switch (reason) {
1668  case DLL_PROCESS_ATTACH:
1669    break;
1670  case DLL_PROCESS_DETACH:
1671    break;
1672  }
1673  return TRUE;
1674}
1675
1676#endif /* !STATIC_BUILD */
1677#endif /* __WIN32__ */
Note: See TracBrowser for help on using the repository browser.