source: tol/toltcl/generic/toltcl.c @ 6f16730

1941-docker-image-to-testdevel
Last change on this file since 6f16730 was 6f16730, checked in by Jorge Pérez <josp.jorge@…>, 17 years ago
  • fixing misspell in Address (related to #705)
  • tol::info address (related to #705)
  • changing version number to 2.0.1

git-svn-id: ​https://www.tol-project.org/svn/tolp/trunk@1134 be4846ae-f051-483a-831f-b64e7d08527f
  • Property mode set to 100644
File size: 45.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_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("address", arg, length)) {
895      if (objc != 3) {
896        Tcl_AppendStringsToObj(obj_result,
897                               "wrong # args: should be '",
898                               Tcl_GetString(objv[0]),
899                               " address {grammar|container objname ?indexes?}'",
900                               NULL);
901        tcl_result = TCL_ERROR;
902      } else {
903        tcl_result = Tol_GetAddresFromObject( interp,
904                                              objv[2], obj_result );
905      }
906    } else if (!strncasecmp("included", arg, length)) {
907      if (objc == 2)
908        tcl_result = Tol_InfoIncluded(interp, obj_result);
909      else if (objc == 3)
910        tcl_result = Tol_InfoFile(interp,objv[2],obj_result);
911      else {
912        Tcl_AppendStringsToObj(obj_result,"wrong # args: should be '",
913                               Tcl_GetString(objv[0]), " include'", NULL);
914        tcl_result = TCL_ERROR;
915      }
916    } else if (!strncasecmp("functions", arg, length))
917      tcl_result = Tol_InfoFunctions(interp, objc-1, objv+1, obj_result);
918    else if (!strncasecmp("grammars", arg, length))
919      tcl_result = Tol_InfoGrammars(interp, objc-1, objv+1, obj_result);
920    else if (!strncasecmp("variables", arg, length))
921      tcl_result = Tol_InfoVariables(interp, objc-1, objv+1, obj_result);
922    else if (!strncasecmp("struct", arg, length))
923      tcl_result = Tol_InfoStruct(interp, objc-1, objv+1, obj_result);
924    else if (!strncasecmp("path", arg, length))
925      tcl_result = Tol_InfoPath(interp, objc-1, objv+1, obj_result);
926    else {
927      Tcl_SetStringObj( obj_result, "bad option '", -1);
928      Tcl_AppendStringsToObj( obj_result, Tcl_GetString( objv[1] ),
929                              "' : must be included, functions, grammars, variables, struct, path or version", NULL );
930      tcl_result = TCL_ERROR;
931    }
932  }
933  Tcl_SetObjResult(interp,obj_result);
934  return tcl_result;
935}
936
937
938/*
939 *----------------------------------------------------------------------
940 *
941 * Tol_InfoStruct --
942 *
943 *        Implements the new Tcl "::tol::info struct" subcommand.
944 *
945 *  ::tol::info struct ?name?
946 *
947 * Results:
948 *       A standard Tcl result
949 *
950 * Side effects:
951 *       None.
952 *
953 *----------------------------------------------------------------------
954 */
955
956static int Tol_InfoStruct(interp, objc, objv, obj_result)
957     Tcl_Interp *interp;             /* Current interpreter */
958     int objc;                       /* Number of arguments */
959     Tcl_Obj *CONST objv[];          /* Argument objects */
960     Tcl_Obj * obj_result;           /* subcommand's result */
961{
962  if ( objc > 2 ) {
963    Tcl_AppendStringsToObj( obj_result, "wrong # args: should be '",
964                      Tcl_GetString(objv[0]),
965                      " struct ?struct-name?'", NULL);
966    return TCL_ERROR;
967  }
968  if ( objc == 1 ) {
969    Tcl_AppendStringsToObj(obj_result, "wrong # args: '",
970                           Tcl_GetString(objv[0]),
971                           " struct\' not implemented yet",
972                           NULL);
973    return TCL_ERROR;
974  }
975  return Tol_GetStructure( interp, objv[1], obj_result );
976/*  return  objc == 1 ? Tol_GetAllStructures( interp, obj_result ) :
977    Tol_GetStructure( interp, objv[1], obj_result ); */
978}
979
980
981/*
982 *----------------------------------------------------------------------
983 *
984 * Tol_InfoPath --
985 *
986 *        Implements the new Tcl "::tol::info path" subcommand.
987 *
988 *  ::tol::info path set-reference
989 *
990 * Results:
991 *       A standard Tcl result
992 *
993 * Side effects:
994 *       None.
995 *
996 *----------------------------------------------------------------------
997 */
998
999static int Tol_InfoPath(interp, objc, objv, obj_result)
1000     Tcl_Interp *interp;             /* Current interpreter */
1001     int objc;                       /* Number of arguments */
1002     Tcl_Obj *CONST objv[];          /* Argument objects */
1003     Tcl_Obj * obj_result;           /* subcommand's result */
1004{
1005  if ( objc != 2 ) {
1006    Tcl_AppendStringsToObj(obj_result,
1007                           "wrong # args: should be '",
1008                           Tcl_GetString(objv[0]),
1009                           " path set'", NULL);
1010    return TCL_ERROR;
1011  }
1012  return Tol_GetSetPath(interp, objv[1], obj_result);
1013}
1014
1015
1016/*
1017 *----------------------------------------------------------------------
1018 *
1019 * Tol_InfoFunctions --
1020 *
1021 *        Implements the subcommand "::tol::info functions ?function?".
1022 *
1023 * Results:
1024 *       A standard Tcl result
1025 *
1026 * Side effects:
1027 *       None.
1028 *
1029 *----------------------------------------------------------------------
1030 */
1031
1032static int
1033Tol_InfoFunctions(interp, objc, objv, obj_result)
1034     Tcl_Interp *interp;             /* Current interpreter */
1035     int objc;                                 /* Number of arguments */
1036     Tcl_Obj *CONST objv[];  /* Argument objects */
1037     Tcl_Obj * obj_result;   /* subcommand's result */
1038{
1039  if ( objc < 2 || objc > 3 ) {
1040    Tcl_AppendStringsToObj(obj_result,
1041                           "wrong # args: should be '",
1042                           Tcl_GetString(objv[0]),
1043                           " functions graname ?funname?'", NULL);
1044    return TCL_ERROR;
1045  }
1046  return  objc == 2 ? Tol_SetFunctionsObj(interp, objv[1], obj_result) :
1047    Tol_SetFunctionInfoObj(objv[1], objv[2], obj_result);
1048}
1049
1050
1051/*
1052 *----------------------------------------------------------------------
1053 *
1054 * Tol_InfoGrammars --
1055 *
1056 *        Implements the subcommand "::tol::info grammars ?grammar?".
1057 *
1058 * Results:
1059 *       A standard Tcl result
1060 *
1061 * Side effects:
1062 *       None.
1063 *
1064 *----------------------------------------------------------------------
1065 */
1066
1067static int
1068Tol_InfoGrammars(interp, objc, objv, obj_result)
1069     Tcl_Interp *interp;             /* Current interpreter */
1070     int objc;                                 /* Number of arguments */
1071     Tcl_Obj *CONST objv[];  /* Argument objects */
1072     Tcl_Obj * obj_result;
1073{
1074  if ( objc > 2 ) {
1075    Tcl_AppendStringsToObj(obj_result,
1076                           "wrong # args: should be '",
1077                           Tcl_GetString(objv[0]), " grammars ?graname?'",
1078                           NULL);
1079    return TCL_ERROR;
1080  }
1081  return  objc == 1 ? Tol_SetGrammarsObj(interp, obj_result) :
1082    Tol_SetGrammarDescObj(interp, objv[1], obj_result);
1083}
1084
1085
1086/*
1087 *----------------------------------------------------------------------
1088 *
1089 * Tol_InfoVariables --
1090 *
1091 *        Implements the new Tcl "::tol::info variables" command.
1092 *
1093 * Results:
1094 *       A standard Tcl result
1095 *
1096 * Side effects:
1097 *       None.
1098 *
1099 *----------------------------------------------------------------------
1100 */
1101
1102static int
1103Tol_InfoVariables(interp, objc, objv, obj_result)
1104Tcl_Interp *interp;             /* Current interpreter */
1105     int objc;                                 /* Number of arguments */
1106     Tcl_Obj *CONST objv[];  /* Argument objects */
1107     Tcl_Obj * obj_result;
1108{
1109//  if ( objc < 2 || objc > 3 ) {
1110  if ( objc != 2 ) {
1111    Tcl_AppendStringsToObj(obj_result,
1112                     "wrong # args: should be '",
1113                     Tcl_GetString(objv[0]),
1114                     " {grammar|container ?objname? ?indexes?}",
1115                     NULL);
1116    return TCL_ERROR;
1117  }
1118//  return  objc == 2 ? Tol_SetVariablesObj(interp, objv[1], obj_result) :
1119//    Tol_SetVariableInfoObj(objv[1], objv[2], obj_result);
1120  return  Tol_SetVariablesObj(interp, objv[1], obj_result);
1121}
1122
1123
1124/*
1125 *----------------------------------------------------------------------
1126 *
1127 * Tol_GetMatrixCmd --
1128 *
1129 *        Implements the new Tcl "::tol::matrix" command.
1130 *
1131 * Results:
1132 *       {matname rows colums {<data>}}
1133 *
1134 * Side effects:
1135 *       None.
1136 *
1137 *----------------------------------------------------------------------
1138 */
1139
1140static int
1141Tol_GetMatrixCmd(ClientData  clientData, /* Not used. */
1142                 Tcl_Interp *interp,     /* Current interpreter */
1143                 int objc,               /* Number of arguments */
1144                 Tcl_Obj *CONST objv[])  /* Argument objects */
1145{
1146  Tcl_Obj * obj_result = Tcl_NewObj();
1147  int tcl_result;
1148
1149  if ( objc != 2) {
1150    Tcl_AppendStringsToObj(obj_result,
1151                           "wrong # args: should be '",
1152                            Tcl_GetString(objv[0]),
1153                            " matrix\"", NULL );
1154    tcl_result = TCL_ERROR;
1155  } else {
1156    tcl_result = Tol_GetMatrixContent(interp,objv[1],obj_result);
1157  }
1158  Tcl_SetObjResult(interp,obj_result);
1159  return tcl_result;
1160}
1161
1162
1163/*
1164 *----------------------------------------------------------------------
1165 *
1166 * Tol_TimeSetCmd --
1167 *
1168 *        Implements the new Tcl "::tol::timeset" command.
1169 *
1170 *       tol::timeset create tms toltms
1171 *       tol::timeset destroy tms ?tms?
1172 *
1173 *       tms start date
1174 *       tms get
1175 *       tms next
1176 *       tms previous
1177 *
1178 * Results:
1179 *       the new tms command
1180 *
1181 * Side effects:
1182 *       None.
1183 *
1184 *----------------------------------------------------------------------
1185 */
1186
1187int Tol_TimeSetCmd ( ClientData clientData, Tcl_Interp *interp,
1188                     int objc, Tcl_Obj *CONST objv[] )
1189{
1190  Tcl_Obj * obj_result = Tcl_NewObj();
1191  int tcl_result;
1192
1193  char * cmdname = Tcl_GetString(objv[0]);
1194
1195  if ( objc < 3 ) {
1196    Tcl_AppendStringsToObj(obj_result,
1197                           "wrong # args: should be '",
1198                           cmdname,
1199                           " option arg ?arg?'", NULL );
1200    tcl_result = TCL_ERROR;
1201  } else {
1202    char * option = Tcl_GetString(objv[1]);
1203    int optlen = strlen(option);
1204
1205    if ( !strncmp(option, "create", optlen) ) {
1206      if ( objc != 4 ) {
1207        Tcl_AppendStringsToObj( obj_result, "wrong # args: should be '",
1208                                cmdname, " ", option,
1209                                " tms toltms'", NULL );
1210        tcl_result = TCL_ERROR;
1211      } else
1212        tcl_result = Tol_CreateTMSCmd( interp, objv[2], objv[3], obj_result );
1213    }
1214    else if ( !strncmp(option, "destroy", optlen) )
1215      tcl_result = Tol_DestroyTMSCmd( interp, objc-2, objv+2, obj_result );
1216    else {
1217      Tcl_AppendStringsToObj(obj_result, "invalid option name '", option,
1218                              "', should be: create or destroy", NULL);
1219      tcl_result = TCL_ERROR;
1220    }
1221  }
1222
1223  Tcl_SetObjResult(interp,obj_result);
1224  return tcl_result;
1225}
1226
1227
1228/*
1229 *----------------------------------------------------------------------
1230 *
1231 * Tol_DateCmd --
1232 *
1233 *        Implements the new Tcl "::tol::date" command.
1234 *
1235 *       tol::date first              -> default first date
1236 *       tol::date last               -> default last  date
1237 *       tol::date now     ?fmt?      -> today date & time
1238 *       tol::date weekday date       -> 0(sunday), 1(monday), ..., 6(saturday)
1239 *       tol::date days    year month -> number of days of month/year
1240 *       tol::date +day    date ?n?   -> date ++ ?n days?
1241 *       tol::date +month  date ?n?   -> date ++ ?n months?
1242 *
1243 * Results:
1244 *       a valid date
1245 *
1246 * Side effects:
1247 *       None.
1248 *
1249 *----------------------------------------------------------------------
1250 */
1251
1252static int Tol_DateCmd ( ClientData clientData, Tcl_Interp *interp,
1253                         int objc, Tcl_Obj *CONST objv[] )
1254{
1255  Tcl_Obj * obj_result = Tcl_NewObj();
1256  int tcl_result;
1257
1258  if ( objc < 2 || objc > 4 ) {
1259    char * cmdname = Tcl_GetString(objv[0]);
1260    Tcl_AppendStringsToObj(obj_result, "wrong # args: should be \n",
1261                           cmdname, " first,\n",
1262                           cmdname, " last,\n",
1263                           cmdname, " now ?fmt?,\n",
1264                           cmdname, " weekday,\n",
1265                           cmdname, " days year month,\n",
1266                           cmdname, " +day date ?n?, or\n",
1267                           cmdname, " +month date ?n?", NULL);
1268    tcl_result = TCL_ERROR;
1269  } else
1270    tcl_result = Tol_DateOption(interp, objc, objv, obj_result);
1271
1272  Tcl_SetObjResult(interp,obj_result);
1273  return tcl_result;
1274}
1275
1276
1277/*
1278 *----------------------------------------------------------------------
1279 *
1280 * Tol_AutoCorCmd --
1281 *
1282 *        Implements the new Tcl "::tol::autocor" command.
1283 *
1284 *       tol::autocor type serie ?lagsize?
1285 *
1286 * Results:
1287 *       {sername sigma size {data of autocorrelation}}
1288 *
1289 * Side effects:
1290 *       None.
1291 *
1292 *----------------------------------------------------------------------
1293 */
1294
1295static int Tol_AutoCorrCmd (ClientData clientData, Tcl_Interp *interp,
1296                            int objc, Tcl_Obj *CONST objv[])
1297{
1298  Tcl_Obj * obj_result = Tcl_NewObj();
1299  int tcl_result;
1300
1301
1302  if ( objc < 3 || objc > 4 ) {
1303    Tcl_AppendStringsToObj( obj_result, "wrong # args: should be '",
1304                           Tcl_GetString(objv[0]),
1305                           " type serie ?lagsize?'", NULL );
1306    tcl_result = TCL_ERROR;
1307  } else
1308    tcl_result = Tol_GetAutoCorr( interp, objc-1, objv+1,
1309                                  obj_result );
1310
1311  Tcl_SetObjResult(interp,obj_result);
1312  return tcl_result;
1313}
1314
1315
1316/*
1317 *----------------------------------------------------------------------
1318 *
1319 * Tol_SerieStatCmd --
1320 *
1321 *       Implements the new Tcl "::tol::seriestat" command.
1322 *
1323 *       tol::seriestat serieref     
1324 *           -> {serie-name {list of stats names & values}}
1325 *
1326 *       tol::seriestat serieref statname ?args?
1327 *            -> return the stat value. (not implemented yet)
1328 *
1329 * Results:
1330 *       
1331 *
1332 * Side effects:
1333 *       None.
1334 *
1335 *----------------------------------------------------------------------
1336 */
1337
1338static
1339int Tol_SerieStatCmd ( ClientData clientData, Tcl_Interp *interp,
1340                       int objc, Tcl_Obj *CONST objv[] )
1341{
1342  Tcl_Obj * obj_result = Tcl_NewObj();
1343  int tcl_result;
1344
1345  if ( objc < 2 ) {
1346    Tcl_AppendStringsToObj( obj_result, "wrong # args: should be '",
1347                           Tcl_GetString(objv[0]),
1348                           " serieref ?statname ?args??'", NULL );
1349    tcl_result = TCL_ERROR;
1350  } else
1351    tcl_result = Tol_ComputeSerieStat(interp,objc-1,objv+1,obj_result);
1352
1353  Tcl_SetObjResult(interp,obj_result);
1354  return tcl_result;
1355}
1356
1357/*
1358 * Tol_StopEvalCmd --
1359 *
1360 * Implement the command tol::stop which try to stop the current evaluation
1361 * flow inside Evaluate.
1362 *
1363 */
1364static
1365int Tol_StopEvalCmd (ClientData clientData, Tcl_Interp *interp,
1366                     int objc, Tcl_Obj *CONST objv[])
1367{
1368  if ( objc != 1 ) {
1369    Tcl_AppendResult(interp, "wrong # args: should be '",
1370                     Tcl_GetString(objv[0]),  "'", NULL);
1371    return TCL_ERROR;
1372  }
1373  return Tol_StopEvaluation();
1374}
1375
1376/*
1377 * Tol_LCFormatCmd --
1378 *
1379 * Implement the command tol::lc_format which format a double given
1380 * the format of reals inside TOL.
1381 *
1382 */
1383static
1384int Tol_LCFormatCmd (ClientData clientData, Tcl_Interp *interp,
1385                     int objc, Tcl_Obj *CONST objv[])
1386{
1387  Tcl_Obj * obj_result;
1388  int tcl_result;
1389
1390  if ( objc != 2 ) {
1391    Tcl_AppendResult( interp, "wrong # args: should be '",
1392                      Tcl_GetString(objv[0]),  " double_value'",
1393                      NULL );
1394    tcl_result = TCL_ERROR;
1395  } else {
1396    obj_result = Tcl_NewObj();
1397    tcl_result = Tol_LCFormat(interp,objv[1],obj_result);
1398    Tcl_SetObjResult(interp, obj_result);
1399  }
1400  return tcl_result;
1401}
1402
1403
1404/*
1405 *----------------------------------------------------------------------
1406 *
1407 * Toltcl_Init --
1408 *
1409 *       Initialize the new package.  The string "Toltcl" in the
1410 *       function name must match the PACKAGE declaration at the top of
1411 *       configure.in.
1412 *
1413 * Results:
1414 *       A standard Tcl result
1415 *
1416 * Side effects:
1417 *       The TolTcl package is created.
1418 *      The commands: ::tol::grammars
1419 *
1420 *----------------------------------------------------------------------
1421 */
1422
1423int
1424Toltcl_Init(Tcl_Interp *interp)
1425{
1426  /* Inicializo la captura de segfault */
1427
1428  InitCrashHandler();
1429 
1430  TT_interp = interp;
1431
1432  if (Tcl_InitStubs(interp, "8.3", 0) == NULL) {
1433    return TCL_ERROR;
1434  }
1435  if (Tcl_PkgRequire(interp, "Tcl", "8.3", 0) == NULL) {
1436    return TCL_ERROR;
1437  }
1438  if (Tcl_PkgProvide(interp, "Toltcl", TOLTCL_VERSION) != TCL_OK) {
1439    return TCL_ERROR;
1440  }
1441 
1442  /*
1443   *  Create the commands
1444   *
1445   */
1446 
1447  Tcl_CreateObjCommand( interp, "::tol::initkernel", Tol_InitKernelCmd,
1448                        (ClientData)NULL, (Tcl_CmdDeleteProc *)NULL );
1449 
1450  /*
1451   *  Inititialize TOL
1452   *
1453   */
1454 
1455  //InitTolKernel();
1456  Tol_InstallHciWriter();
1457  Tol_InstallMethodsHook();
1458 
1459  return TCL_OK;
1460}
1461
1462#ifdef __WIN32__
1463#ifndef STATIC_BUILD
1464
1465#include <windows.h>
1466
1467/*
1468 * The following declaration is for the VC++ DLL entry point.
1469 */
1470
1471BOOL APIENTRY           DllMain(HINSTANCE hInst, DWORD reason,
1472                                LPVOID reserved);
1473/*
1474 *----------------------------------------------------------------------
1475 *
1476 * DllMain --
1477 *
1478 *      This routine is called by the VC++ C run time library init
1479 *      code, or the DllEntryPoint routine.
1480 *
1481 * Results:
1482 *      TRUE on sucess, FALSE on failure.
1483 *
1484 * Side effects:
1485 *
1486 *----------------------------------------------------------------------
1487 */
1488
1489BOOL APIENTRY
1490DllMain(hInst, reason, reserved)
1491     HINSTANCE hInst;    /* Library instance handle. */
1492     DWORD reason;       /* Reason this function is being called. */
1493     LPVOID reserved;    /* Not used. */
1494{
1495  switch (reason) {
1496  case DLL_PROCESS_ATTACH:
1497    break;
1498  case DLL_PROCESS_DETACH:
1499    break;
1500  }
1501  return TRUE;
1502}
1503
1504#endif /* !STATIC_BUILD */
1505#endif /* __WIN32__ */
Note: See TracBrowser for help on using the repository browser.