source: tol/toltcl/generic/toltcl.c @ 3475b98

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

merging from NameBlock/VMatrix branch

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