source: tol/toltcl/generic/toltcl.c @ 2f5c82f1

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

refs #1323, Tol_InstallHciWriter() must be called only if tol has not being initialized

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