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

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

refs #1429, se chequea por idioma en invocación de initkernel, argumentos válidos son: en (0) o en (1), si el argumento es inválido se invoca InitKernel con -1

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