source: tol/toltcl/generic/toltcl.c @ 87e95d3

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

New command tol::foreach in order to makes it clear the way a Set is iterated from Tcl.

As an example:

set it 1
tol::foreach memb { Set LinRegMet } {

array set it_info $memb
puts "Informacion para el item $it"
parray it_info
incr it

}

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