source: tol/toltcl/generic/toltcl.c @ b47c991

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

refs #1259, implementamos el argumento '-np' en tol::initlibrary, interpretamos la opcion -np en tolsh y tolbase

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