/[dtapublic]/projs/trunk/shared_source/c_tcl_base_7_5_w_mods/tclbasic.c
ViewVC logotype

Annotation of /projs/trunk/shared_source/c_tcl_base_7_5_w_mods/tclbasic.c

Parent Directory Parent Directory | Revision Log Revision Log


Revision 25 - (hide annotations) (download)
Sat Oct 8 06:43:03 2016 UTC (7 years, 8 months ago) by dashley
Original Path: sf_code/esrgpcpj/shared/tcl_base/tclbasic.c
File MIME type: text/plain
File size: 134759 byte(s)
Initial commit.
1 dashley 25 /* $Header: /cvsroot/esrg/sfesrg/esrgpcpj/shared/tcl_base/tclbasic.c,v 1.1.1.1 2001/06/13 04:33:43 dtashley Exp $ */
2    
3     /*
4     * tclBasic.c --
5     *
6     * Contains the basic facilities for TCL command interpretation,
7     * including interpreter creation and deletion, command creation
8     * and deletion, and command parsing and execution.
9     *
10     * Copyright (c) 1987-1994 The Regents of the University of California.
11     * Copyright (c) 1994-1997 Sun Microsystems, Inc.
12     * Copyright (c) 1998-1999 by Scriptics Corporation.
13     *
14     * See the file "license.terms" for information on usage and redistribution
15     * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
16     *
17     * RCS: @(#) $Id: tclbasic.c,v 1.1.1.1 2001/06/13 04:33:43 dtashley Exp $
18     */
19    
20     #include "tclInt.h"
21     #include "tclCompile.h"
22     #ifndef TCL_GENERIC_ONLY
23     # include "tclPort.h"
24     #endif
25    
26     /*
27     * Static procedures in this file:
28     */
29    
30     static void DeleteInterpProc _ANSI_ARGS_((Tcl_Interp *interp));
31     static void ProcessUnexpectedResult _ANSI_ARGS_((
32     Tcl_Interp *interp, int returnCode));
33     static void RecordTracebackInfo _ANSI_ARGS_((
34     Tcl_Interp *interp, Tcl_Obj *objPtr,
35     int numSrcBytes));
36    
37     extern TclStubs tclStubs;
38    
39     /*
40     * The following structure defines the commands in the Tcl core.
41     */
42    
43     typedef struct {
44     char *name; /* Name of object-based command. */
45     Tcl_CmdProc *proc; /* String-based procedure for command. */
46     Tcl_ObjCmdProc *objProc; /* Object-based procedure for command. */
47     CompileProc *compileProc; /* Procedure called to compile command. */
48     int isSafe; /* If non-zero, command will be present
49     * in safe interpreter. Otherwise it will
50     * be hidden. */
51     } CmdInfo;
52    
53     /*
54     * The built-in commands, and the procedures that implement them:
55     */
56    
57     static CmdInfo builtInCmds[] = {
58     /*
59     * Commands in the generic core. Note that at least one of the proc or
60     * objProc members should be non-NULL. This avoids infinitely recursive
61     * calls between TclInvokeObjectCommand and TclInvokeStringCommand if a
62     * command name is computed at runtime and results in the name of a
63     * compiled command.
64     */
65    
66     {"append", (Tcl_CmdProc *) NULL, Tcl_AppendObjCmd,
67     (CompileProc *) NULL, 1},
68     {"array", (Tcl_CmdProc *) NULL, Tcl_ArrayObjCmd,
69     (CompileProc *) NULL, 1},
70     {"binary", (Tcl_CmdProc *) NULL, Tcl_BinaryObjCmd,
71     (CompileProc *) NULL, 1},
72     {"break", (Tcl_CmdProc *) NULL, Tcl_BreakObjCmd,
73     TclCompileBreakCmd, 1},
74     {"case", (Tcl_CmdProc *) NULL, Tcl_CaseObjCmd,
75     (CompileProc *) NULL, 1},
76     {"catch", (Tcl_CmdProc *) NULL, Tcl_CatchObjCmd,
77     TclCompileCatchCmd, 1},
78     {"clock", (Tcl_CmdProc *) NULL, Tcl_ClockObjCmd,
79     (CompileProc *) NULL, 1},
80     {"concat", (Tcl_CmdProc *) NULL, Tcl_ConcatObjCmd,
81     (CompileProc *) NULL, 1},
82     {"continue", (Tcl_CmdProc *) NULL, Tcl_ContinueObjCmd,
83     TclCompileContinueCmd, 1},
84     {"encoding", (Tcl_CmdProc *) NULL, Tcl_EncodingObjCmd,
85     (CompileProc *) NULL, 0},
86     {"error", (Tcl_CmdProc *) NULL, Tcl_ErrorObjCmd,
87     (CompileProc *) NULL, 1},
88     {"eval", (Tcl_CmdProc *) NULL, Tcl_EvalObjCmd,
89     (CompileProc *) NULL, 1},
90     {"exit", (Tcl_CmdProc *) NULL, Tcl_ExitObjCmd,
91     (CompileProc *) NULL, 0},
92     {"expr", (Tcl_CmdProc *) NULL, Tcl_ExprObjCmd,
93     TclCompileExprCmd, 1},
94     {"fcopy", (Tcl_CmdProc *) NULL, Tcl_FcopyObjCmd,
95     (CompileProc *) NULL, 1},
96     {"fileevent", (Tcl_CmdProc *) NULL, Tcl_FileEventObjCmd,
97     (CompileProc *) NULL, 1},
98     {"for", (Tcl_CmdProc *) NULL, Tcl_ForObjCmd,
99     TclCompileForCmd, 1},
100     {"foreach", (Tcl_CmdProc *) NULL, Tcl_ForeachObjCmd,
101     TclCompileForeachCmd, 1},
102     {"format", (Tcl_CmdProc *) NULL, Tcl_FormatObjCmd,
103     (CompileProc *) NULL, 1},
104     {"global", (Tcl_CmdProc *) NULL, Tcl_GlobalObjCmd,
105     (CompileProc *) NULL, 1},
106     {"if", (Tcl_CmdProc *) NULL, Tcl_IfObjCmd,
107     TclCompileIfCmd, 1},
108     {"incr", (Tcl_CmdProc *) NULL, Tcl_IncrObjCmd,
109     TclCompileIncrCmd, 1},
110     {"info", (Tcl_CmdProc *) NULL, Tcl_InfoObjCmd,
111     (CompileProc *) NULL, 1},
112     {"join", (Tcl_CmdProc *) NULL, Tcl_JoinObjCmd,
113     (CompileProc *) NULL, 1},
114     {"lappend", (Tcl_CmdProc *) NULL, Tcl_LappendObjCmd,
115     (CompileProc *) NULL, 1},
116     {"lindex", (Tcl_CmdProc *) NULL, Tcl_LindexObjCmd,
117     (CompileProc *) NULL, 1},
118     {"linsert", (Tcl_CmdProc *) NULL, Tcl_LinsertObjCmd,
119     (CompileProc *) NULL, 1},
120     {"list", (Tcl_CmdProc *) NULL, Tcl_ListObjCmd,
121     (CompileProc *) NULL, 1},
122     {"llength", (Tcl_CmdProc *) NULL, Tcl_LlengthObjCmd,
123     (CompileProc *) NULL, 1},
124     {"load", (Tcl_CmdProc *) NULL, Tcl_LoadObjCmd,
125     (CompileProc *) NULL, 0},
126     {"lrange", (Tcl_CmdProc *) NULL, Tcl_LrangeObjCmd,
127     (CompileProc *) NULL, 1},
128     {"lreplace", (Tcl_CmdProc *) NULL, Tcl_LreplaceObjCmd,
129     (CompileProc *) NULL, 1},
130     {"lsearch", (Tcl_CmdProc *) NULL, Tcl_LsearchObjCmd,
131     (CompileProc *) NULL, 1},
132     {"lsort", (Tcl_CmdProc *) NULL, Tcl_LsortObjCmd,
133     (CompileProc *) NULL, 1},
134     {"namespace", (Tcl_CmdProc *) NULL, Tcl_NamespaceObjCmd,
135     (CompileProc *) NULL, 1},
136     {"package", (Tcl_CmdProc *) NULL, Tcl_PackageObjCmd,
137     (CompileProc *) NULL, 1},
138     {"proc", (Tcl_CmdProc *) NULL, Tcl_ProcObjCmd,
139     (CompileProc *) NULL, 1},
140     {"regexp", (Tcl_CmdProc *) NULL, Tcl_RegexpObjCmd,
141     (CompileProc *) NULL, 1},
142     {"regsub", (Tcl_CmdProc *) NULL, Tcl_RegsubObjCmd,
143     (CompileProc *) NULL, 1},
144     {"rename", (Tcl_CmdProc *) NULL, Tcl_RenameObjCmd,
145     (CompileProc *) NULL, 1},
146     {"return", (Tcl_CmdProc *) NULL, Tcl_ReturnObjCmd,
147     (CompileProc *) NULL, 1},
148     {"scan", (Tcl_CmdProc *) NULL, Tcl_ScanObjCmd,
149     (CompileProc *) NULL, 1},
150     {"set", (Tcl_CmdProc *) NULL, Tcl_SetObjCmd,
151     TclCompileSetCmd, 1},
152     {"split", (Tcl_CmdProc *) NULL, Tcl_SplitObjCmd,
153     (CompileProc *) NULL, 1},
154     {"string", (Tcl_CmdProc *) NULL, Tcl_StringObjCmd,
155     (CompileProc *) NULL, 1},
156     {"subst", (Tcl_CmdProc *) NULL, Tcl_SubstObjCmd,
157     (CompileProc *) NULL, 1},
158     {"switch", (Tcl_CmdProc *) NULL, Tcl_SwitchObjCmd,
159     (CompileProc *) NULL, 1},
160     {"trace", (Tcl_CmdProc *) NULL, Tcl_TraceObjCmd,
161     (CompileProc *) NULL, 1},
162     {"unset", (Tcl_CmdProc *) NULL, Tcl_UnsetObjCmd,
163     (CompileProc *) NULL, 1},
164     {"uplevel", (Tcl_CmdProc *) NULL, Tcl_UplevelObjCmd,
165     (CompileProc *) NULL, 1},
166     {"upvar", (Tcl_CmdProc *) NULL, Tcl_UpvarObjCmd,
167     (CompileProc *) NULL, 1},
168     {"variable", (Tcl_CmdProc *) NULL, Tcl_VariableObjCmd,
169     (CompileProc *) NULL, 1},
170     {"while", (Tcl_CmdProc *) NULL, Tcl_WhileObjCmd,
171     TclCompileWhileCmd, 1},
172    
173     /*
174     * Commands in the UNIX core:
175     */
176    
177     #ifndef TCL_GENERIC_ONLY
178     {"after", (Tcl_CmdProc *) NULL, Tcl_AfterObjCmd,
179     (CompileProc *) NULL, 1},
180     {"cd", (Tcl_CmdProc *) NULL, Tcl_CdObjCmd,
181     (CompileProc *) NULL, 0},
182     {"close", (Tcl_CmdProc *) NULL, Tcl_CloseObjCmd,
183     (CompileProc *) NULL, 1},
184     {"eof", (Tcl_CmdProc *) NULL, Tcl_EofObjCmd,
185     (CompileProc *) NULL, 1},
186     {"fblocked", (Tcl_CmdProc *) NULL, Tcl_FblockedObjCmd,
187     (CompileProc *) NULL, 1},
188     {"fconfigure", (Tcl_CmdProc *) NULL, Tcl_FconfigureObjCmd,
189     (CompileProc *) NULL, 0},
190     {"file", (Tcl_CmdProc *) NULL, Tcl_FileObjCmd,
191     (CompileProc *) NULL, 0},
192     {"flush", (Tcl_CmdProc *) NULL, Tcl_FlushObjCmd,
193     (CompileProc *) NULL, 1},
194     {"gets", (Tcl_CmdProc *) NULL, Tcl_GetsObjCmd,
195     (CompileProc *) NULL, 1},
196     {"glob", (Tcl_CmdProc *) NULL, Tcl_GlobObjCmd,
197     (CompileProc *) NULL, 0},
198     {"open", (Tcl_CmdProc *) NULL, Tcl_OpenObjCmd,
199     (CompileProc *) NULL, 0},
200     {"pid", (Tcl_CmdProc *) NULL, Tcl_PidObjCmd,
201     (CompileProc *) NULL, 1},
202     {"puts", (Tcl_CmdProc *) NULL, Tcl_PutsObjCmd,
203     (CompileProc *) NULL, 1},
204     {"pwd", (Tcl_CmdProc *) NULL, Tcl_PwdObjCmd,
205     (CompileProc *) NULL, 0},
206     {"read", (Tcl_CmdProc *) NULL, Tcl_ReadObjCmd,
207     (CompileProc *) NULL, 1},
208     {"seek", (Tcl_CmdProc *) NULL, Tcl_SeekObjCmd,
209     (CompileProc *) NULL, 1},
210     {"socket", (Tcl_CmdProc *) NULL, Tcl_SocketObjCmd,
211     (CompileProc *) NULL, 0},
212     {"tell", (Tcl_CmdProc *) NULL, Tcl_TellObjCmd,
213     (CompileProc *) NULL, 1},
214     {"time", (Tcl_CmdProc *) NULL, Tcl_TimeObjCmd,
215     (CompileProc *) NULL, 1},
216     {"update", (Tcl_CmdProc *) NULL, Tcl_UpdateObjCmd,
217     (CompileProc *) NULL, 1},
218     {"vwait", (Tcl_CmdProc *) NULL, Tcl_VwaitObjCmd,
219     (CompileProc *) NULL, 1},
220    
221     #ifdef MAC_TCL
222     {"beep", (Tcl_CmdProc *) NULL, Tcl_BeepObjCmd,
223     (CompileProc *) NULL, 0},
224     {"echo", Tcl_EchoCmd, (Tcl_ObjCmdProc *) NULL,
225     (CompileProc *) NULL, 0},
226     {"ls", (Tcl_CmdProc *) NULL, Tcl_LsObjCmd,
227     (CompileProc *) NULL, 0},
228     {"resource", (Tcl_CmdProc *) NULL, Tcl_ResourceObjCmd,
229     (CompileProc *) NULL, 1},
230     {"source", (Tcl_CmdProc *) NULL, Tcl_MacSourceObjCmd,
231     (CompileProc *) NULL, 0},
232     #else
233     {"exec", (Tcl_CmdProc *) NULL, Tcl_ExecObjCmd,
234     (CompileProc *) NULL, 0},
235     {"source", (Tcl_CmdProc *) NULL, Tcl_SourceObjCmd,
236     (CompileProc *) NULL, 0},
237     #endif /* MAC_TCL */
238    
239     #endif /* TCL_GENERIC_ONLY */
240     {NULL, (Tcl_CmdProc *) NULL, (Tcl_ObjCmdProc *) NULL,
241     (CompileProc *) NULL, 0}
242     };
243    
244    
245     /*
246     *----------------------------------------------------------------------
247     *
248     * Tcl_CreateInterp --
249     *
250     * Create a new TCL command interpreter.
251     *
252     * Results:
253     * The return value is a token for the interpreter, which may be
254     * used in calls to procedures like Tcl_CreateCmd, Tcl_Eval, or
255     * Tcl_DeleteInterp.
256     *
257     * Side effects:
258     * The command interpreter is initialized with an empty variable
259     * table and the built-in commands.
260     *
261     *----------------------------------------------------------------------
262     */
263    
264     Tcl_Interp *
265     Tcl_CreateInterp()
266     {
267     Interp *iPtr;
268     Tcl_Interp *interp;
269     Command *cmdPtr;
270     BuiltinFunc *builtinFuncPtr;
271     MathFunc *mathFuncPtr;
272     Tcl_HashEntry *hPtr;
273     CmdInfo *cmdInfoPtr;
274     int i;
275     union {
276     char c[sizeof(short)];
277     short s;
278     } order;
279     #ifdef TCL_COMPILE_STATS
280     ByteCodeStats *statsPtr;
281     #endif /* TCL_COMPILE_STATS */
282    
283     TclInitSubsystems(NULL);
284    
285     /*
286     * Panic if someone updated the CallFrame structure without
287     * also updating the Tcl_CallFrame structure (or vice versa).
288     */
289    
290     if (sizeof(Tcl_CallFrame) != sizeof(CallFrame)) {
291     /*NOTREACHED*/
292     panic("Tcl_CallFrame and CallFrame are not the same size");
293     }
294    
295     /*
296     * Initialize support for namespaces and create the global namespace
297     * (whose name is ""; an alias is "::"). This also initializes the
298     * Tcl object type table and other object management code.
299     */
300    
301     iPtr = (Interp *) ckalloc(sizeof(Interp));
302     interp = (Tcl_Interp *) iPtr;
303    
304     iPtr->result = iPtr->resultSpace;
305     iPtr->freeProc = NULL;
306     iPtr->errorLine = 0;
307     iPtr->objResultPtr = Tcl_NewObj();
308     Tcl_IncrRefCount(iPtr->objResultPtr);
309     iPtr->handle = TclHandleCreate(iPtr);
310     iPtr->globalNsPtr = NULL;
311     iPtr->hiddenCmdTablePtr = NULL;
312     iPtr->interpInfo = NULL;
313     Tcl_InitHashTable(&iPtr->mathFuncTable, TCL_STRING_KEYS);
314    
315     iPtr->numLevels = 0;
316     iPtr->maxNestingDepth = 1000;
317     iPtr->framePtr = NULL;
318     iPtr->varFramePtr = NULL;
319     iPtr->activeTracePtr = NULL;
320     iPtr->returnCode = TCL_OK;
321     iPtr->errorInfo = NULL;
322     iPtr->errorCode = NULL;
323    
324     iPtr->appendResult = NULL;
325     iPtr->appendAvl = 0;
326     iPtr->appendUsed = 0;
327    
328     Tcl_InitHashTable(&iPtr->packageTable, TCL_STRING_KEYS);
329     iPtr->packageUnknown = NULL;
330     iPtr->cmdCount = 0;
331     iPtr->termOffset = 0;
332     TclInitLiteralTable(&(iPtr->literalTable));
333     iPtr->compileEpoch = 0;
334     iPtr->compiledProcPtr = NULL;
335     iPtr->resolverPtr = NULL;
336     iPtr->evalFlags = 0;
337     iPtr->scriptFile = NULL;
338     iPtr->flags = 0;
339     iPtr->tracePtr = NULL;
340     iPtr->assocData = (Tcl_HashTable *) NULL;
341     iPtr->execEnvPtr = NULL; /* set after namespaces initialized */
342     iPtr->emptyObjPtr = Tcl_NewObj(); /* another empty object */
343     Tcl_IncrRefCount(iPtr->emptyObjPtr);
344     iPtr->resultSpace[0] = 0;
345    
346     iPtr->globalNsPtr = NULL; /* force creation of global ns below */
347     iPtr->globalNsPtr = (Namespace *) Tcl_CreateNamespace(interp, "",
348     (ClientData) NULL, (Tcl_NamespaceDeleteProc *) NULL);
349     if (iPtr->globalNsPtr == NULL) {
350     panic("Tcl_CreateInterp: can't create global namespace");
351     }
352    
353     /*
354     * Initialize support for code compilation and execution. We call
355     * TclCreateExecEnv after initializing namespaces since it tries to
356     * reference a Tcl variable (it links to the Tcl "tcl_traceExec"
357     * variable).
358     */
359    
360     iPtr->execEnvPtr = TclCreateExecEnv(interp);
361    
362     /*
363     * Initialize the compilation and execution statistics kept for this
364     * interpreter.
365     */
366    
367     #ifdef TCL_COMPILE_STATS
368     statsPtr = &(iPtr->stats);
369     statsPtr->numExecutions = 0;
370     statsPtr->numCompilations = 0;
371     statsPtr->numByteCodesFreed = 0;
372     (VOID *) memset(statsPtr->instructionCount, 0,
373     sizeof(statsPtr->instructionCount));
374    
375     statsPtr->totalSrcBytes = 0.0;
376     statsPtr->totalByteCodeBytes = 0.0;
377     statsPtr->currentSrcBytes = 0.0;
378     statsPtr->currentByteCodeBytes = 0.0;
379     (VOID *) memset(statsPtr->srcCount, 0, sizeof(statsPtr->srcCount));
380     (VOID *) memset(statsPtr->byteCodeCount, 0,
381     sizeof(statsPtr->byteCodeCount));
382     (VOID *) memset(statsPtr->lifetimeCount, 0,
383     sizeof(statsPtr->lifetimeCount));
384    
385     statsPtr->currentInstBytes = 0.0;
386     statsPtr->currentLitBytes = 0.0;
387     statsPtr->currentExceptBytes = 0.0;
388     statsPtr->currentAuxBytes = 0.0;
389     statsPtr->currentCmdMapBytes = 0.0;
390    
391     statsPtr->numLiteralsCreated = 0;
392     statsPtr->totalLitStringBytes = 0.0;
393     statsPtr->currentLitStringBytes = 0.0;
394     (VOID *) memset(statsPtr->literalCount, 0,
395     sizeof(statsPtr->literalCount));
396     #endif /* TCL_COMPILE_STATS */
397    
398     /*
399     * Initialise the stub table pointer.
400     */
401    
402     iPtr->stubTable = &tclStubs;
403    
404    
405     /*
406     * Create the core commands. Do it here, rather than calling
407     * Tcl_CreateCommand, because it's faster (there's no need to check for
408     * a pre-existing command by the same name). If a command has a
409     * Tcl_CmdProc but no Tcl_ObjCmdProc, set the Tcl_ObjCmdProc to
410     * TclInvokeStringCommand. This is an object-based wrapper procedure
411     * that extracts strings, calls the string procedure, and creates an
412     * object for the result. Similarly, if a command has a Tcl_ObjCmdProc
413     * but no Tcl_CmdProc, set the Tcl_CmdProc to TclInvokeObjectCommand.
414     */
415    
416     for (cmdInfoPtr = builtInCmds; cmdInfoPtr->name != NULL;
417     cmdInfoPtr++) {
418     int new;
419     Tcl_HashEntry *hPtr;
420    
421     if ((cmdInfoPtr->proc == (Tcl_CmdProc *) NULL)
422     && (cmdInfoPtr->objProc == (Tcl_ObjCmdProc *) NULL)
423     && (cmdInfoPtr->compileProc == (CompileProc *) NULL)) {
424     panic("Tcl_CreateInterp: builtin command with NULL string and object command procs and a NULL compile proc\n");
425     }
426    
427     hPtr = Tcl_CreateHashEntry(&iPtr->globalNsPtr->cmdTable,
428     cmdInfoPtr->name, &new);
429     if (new) {
430     cmdPtr = (Command *) ckalloc(sizeof(Command));
431     cmdPtr->hPtr = hPtr;
432     cmdPtr->nsPtr = iPtr->globalNsPtr;
433     cmdPtr->refCount = 1;
434     cmdPtr->cmdEpoch = 0;
435     cmdPtr->compileProc = cmdInfoPtr->compileProc;
436     if (cmdInfoPtr->proc == (Tcl_CmdProc *) NULL) {
437     cmdPtr->proc = TclInvokeObjectCommand;
438     cmdPtr->clientData = (ClientData) cmdPtr;
439     } else {
440     cmdPtr->proc = cmdInfoPtr->proc;
441     cmdPtr->clientData = (ClientData) NULL;
442     }
443     if (cmdInfoPtr->objProc == (Tcl_ObjCmdProc *) NULL) {
444     cmdPtr->objProc = TclInvokeStringCommand;
445     cmdPtr->objClientData = (ClientData) cmdPtr;
446     } else {
447     cmdPtr->objProc = cmdInfoPtr->objProc;
448     cmdPtr->objClientData = (ClientData) NULL;
449     }
450     cmdPtr->deleteProc = NULL;
451     cmdPtr->deleteData = (ClientData) NULL;
452     cmdPtr->deleted = 0;
453     cmdPtr->importRefPtr = NULL;
454     Tcl_SetHashValue(hPtr, cmdPtr);
455     }
456     }
457    
458     /*
459     * Register the builtin math functions.
460     */
461    
462     i = 0;
463     for (builtinFuncPtr = builtinFuncTable; builtinFuncPtr->name != NULL;
464     builtinFuncPtr++) {
465     Tcl_CreateMathFunc((Tcl_Interp *) iPtr, builtinFuncPtr->name,
466     builtinFuncPtr->numArgs, builtinFuncPtr->argTypes,
467     (Tcl_MathProc *) NULL, (ClientData) 0);
468     hPtr = Tcl_FindHashEntry(&iPtr->mathFuncTable,
469     builtinFuncPtr->name);
470     if (hPtr == NULL) {
471     panic("Tcl_CreateInterp: Tcl_CreateMathFunc incorrectly registered '%s'", builtinFuncPtr->name);
472     return NULL;
473     }
474     mathFuncPtr = (MathFunc *) Tcl_GetHashValue(hPtr);
475     mathFuncPtr->builtinFuncIndex = i;
476     i++;
477     }
478     iPtr->flags |= EXPR_INITIALIZED;
479    
480     /*
481     * Do Multiple/Safe Interps Tcl init stuff
482     */
483    
484     TclInterpInit(interp);
485    
486     /*
487     * We used to create the "errorInfo" and "errorCode" global vars at this
488     * point because so much of the Tcl implementation assumes they already
489     * exist. This is not quite enough, however, since they can be unset
490     * at any time.
491     *
492     * There are 2 choices:
493     * + Check every place where a GetVar of those is used
494     * and the NULL result is not checked (like in tclLoad.c)
495     * + Make SetVar,... NULL friendly
496     * We choose the second option because :
497     * + It is easy and low cost to check for NULL pointer before
498     * calling strlen()
499     * + It can be helpfull to other people using those API
500     * + Passing a NULL value to those closest 'meaning' is empty string
501     * (specially with the new objects where 0 bytes strings are ok)
502     * So the following init is commented out: -- dl
503     *
504     * (void) Tcl_SetVar2((Tcl_Interp *)iPtr, "errorInfo", (char *) NULL,
505     * "", TCL_GLOBAL_ONLY);
506     * (void) Tcl_SetVar2((Tcl_Interp *)iPtr, "errorCode", (char *) NULL,
507     * "NONE", TCL_GLOBAL_ONLY);
508     */
509    
510     #ifndef TCL_GENERIC_ONLY
511     TclSetupEnv(interp);
512     #endif
513    
514     /*
515     * Compute the byte order of this machine.
516     */
517    
518     order.s = 1;
519     Tcl_SetVar2(interp, "tcl_platform", "byteOrder",
520     ((order.c[0] == 1) ? "littleEndian" : "bigEndian"),
521     TCL_GLOBAL_ONLY);
522    
523     /*
524     * Set up other variables such as tcl_version and tcl_library
525     */
526    
527     Tcl_SetVar(interp, "tcl_patchLevel", TCL_PATCH_LEVEL, TCL_GLOBAL_ONLY);
528     Tcl_SetVar(interp, "tcl_version", TCL_VERSION, TCL_GLOBAL_ONLY);
529     Tcl_TraceVar2(interp, "tcl_precision", (char *) NULL,
530     TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
531     TclPrecTraceProc, (ClientData) NULL);
532     TclpSetVariables(interp);
533    
534     #ifdef TCL_THREADS
535     /*
536     * The existence of the "threaded" element of the tcl_platform array indicates
537     * that this particular Tcl shell has been compiled with threads turned on.
538     * Using "info exists tcl_platform(threaded)" a Tcl script can introspect on the
539     * interpreter level of thread safety.
540     */
541    
542    
543     Tcl_SetVar2(interp, "tcl_platform", "threaded", "1",
544     TCL_GLOBAL_ONLY);
545     #endif
546    
547     /*
548     * Register Tcl's version number.
549     */
550    
551     Tcl_PkgProvideEx(interp, "Tcl", TCL_VERSION, (ClientData) &tclStubs);
552    
553     #ifdef Tcl_InitStubs
554     #undef Tcl_InitStubs
555     #endif
556     Tcl_InitStubs(interp, TCL_VERSION, 1);
557    
558     return interp;
559     }
560    
561     /*
562     *----------------------------------------------------------------------
563     *
564     * TclHideUnsafeCommands --
565     *
566     * Hides base commands that are not marked as safe from this
567     * interpreter.
568     *
569     * Results:
570     * TCL_OK if it succeeds, TCL_ERROR else.
571     *
572     * Side effects:
573     * Hides functionality in an interpreter.
574     *
575     *----------------------------------------------------------------------
576     */
577    
578     int
579     TclHideUnsafeCommands(interp)
580     Tcl_Interp *interp; /* Hide commands in this interpreter. */
581     {
582     register CmdInfo *cmdInfoPtr;
583    
584     if (interp == (Tcl_Interp *) NULL) {
585     return TCL_ERROR;
586     }
587     for (cmdInfoPtr = builtInCmds; cmdInfoPtr->name != NULL; cmdInfoPtr++) {
588     if (!cmdInfoPtr->isSafe) {
589     Tcl_HideCommand(interp, cmdInfoPtr->name, cmdInfoPtr->name);
590     }
591     }
592     return TCL_OK;
593     }
594    
595     /*
596     *--------------------------------------------------------------
597     *
598     * Tcl_CallWhenDeleted --
599     *
600     * Arrange for a procedure to be called before a given
601     * interpreter is deleted. The procedure is called as soon
602     * as Tcl_DeleteInterp is called; if Tcl_CallWhenDeleted is
603     * called on an interpreter that has already been deleted,
604     * the procedure will be called when the last Tcl_Release is
605     * done on the interpreter.
606     *
607     * Results:
608     * None.
609     *
610     * Side effects:
611     * When Tcl_DeleteInterp is invoked to delete interp,
612     * proc will be invoked. See the manual entry for
613     * details.
614     *
615     *--------------------------------------------------------------
616     */
617    
618     void
619     Tcl_CallWhenDeleted(interp, proc, clientData)
620     Tcl_Interp *interp; /* Interpreter to watch. */
621     Tcl_InterpDeleteProc *proc; /* Procedure to call when interpreter
622     * is about to be deleted. */
623     ClientData clientData; /* One-word value to pass to proc. */
624     {
625     Interp *iPtr = (Interp *) interp;
626     static int assocDataCounter = 0;
627     #ifdef TCL_THREADS
628     static Tcl_Mutex assocMutex;
629     #endif
630     int new;
631     char buffer[32 + TCL_INTEGER_SPACE];
632     AssocData *dPtr = (AssocData *) ckalloc(sizeof(AssocData));
633     Tcl_HashEntry *hPtr;
634    
635     Tcl_MutexLock(&assocMutex);
636     sprintf(buffer, "Assoc Data Key #%d", assocDataCounter);
637     assocDataCounter++;
638     Tcl_MutexUnlock(&assocMutex);
639    
640     if (iPtr->assocData == (Tcl_HashTable *) NULL) {
641     iPtr->assocData = (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable));
642     Tcl_InitHashTable(iPtr->assocData, TCL_STRING_KEYS);
643     }
644     hPtr = Tcl_CreateHashEntry(iPtr->assocData, buffer, &new);
645     dPtr->proc = proc;
646     dPtr->clientData = clientData;
647     Tcl_SetHashValue(hPtr, dPtr);
648     }
649    
650     /*
651     *--------------------------------------------------------------
652     *
653     * Tcl_DontCallWhenDeleted --
654     *
655     * Cancel the arrangement for a procedure to be called when
656     * a given interpreter is deleted.
657     *
658     * Results:
659     * None.
660     *
661     * Side effects:
662     * If proc and clientData were previously registered as a
663     * callback via Tcl_CallWhenDeleted, they are unregistered.
664     * If they weren't previously registered then nothing
665     * happens.
666     *
667     *--------------------------------------------------------------
668     */
669    
670     void
671     Tcl_DontCallWhenDeleted(interp, proc, clientData)
672     Tcl_Interp *interp; /* Interpreter to watch. */
673     Tcl_InterpDeleteProc *proc; /* Procedure to call when interpreter
674     * is about to be deleted. */
675     ClientData clientData; /* One-word value to pass to proc. */
676     {
677     Interp *iPtr = (Interp *) interp;
678     Tcl_HashTable *hTablePtr;
679     Tcl_HashSearch hSearch;
680     Tcl_HashEntry *hPtr;
681     AssocData *dPtr;
682    
683     hTablePtr = iPtr->assocData;
684     if (hTablePtr == (Tcl_HashTable *) NULL) {
685     return;
686     }
687     for (hPtr = Tcl_FirstHashEntry(hTablePtr, &hSearch); hPtr != NULL;
688     hPtr = Tcl_NextHashEntry(&hSearch)) {
689     dPtr = (AssocData *) Tcl_GetHashValue(hPtr);
690     if ((dPtr->proc == proc) && (dPtr->clientData == clientData)) {
691     ckfree((char *) dPtr);
692     Tcl_DeleteHashEntry(hPtr);
693     return;
694     }
695     }
696     }
697    
698     /*
699     *----------------------------------------------------------------------
700     *
701     * Tcl_SetAssocData --
702     *
703     * Creates a named association between user-specified data, a delete
704     * function and this interpreter. If the association already exists
705     * the data is overwritten with the new data. The delete function will
706     * be invoked when the interpreter is deleted.
707     *
708     * Results:
709     * None.
710     *
711     * Side effects:
712     * Sets the associated data, creates the association if needed.
713     *
714     *----------------------------------------------------------------------
715     */
716    
717     void
718     Tcl_SetAssocData(interp, name, proc, clientData)
719     Tcl_Interp *interp; /* Interpreter to associate with. */
720     char *name; /* Name for association. */
721     Tcl_InterpDeleteProc *proc; /* Proc to call when interpreter is
722     * about to be deleted. */
723     ClientData clientData; /* One-word value to pass to proc. */
724     {
725     Interp *iPtr = (Interp *) interp;
726     AssocData *dPtr;
727     Tcl_HashEntry *hPtr;
728     int new;
729    
730     if (iPtr->assocData == (Tcl_HashTable *) NULL) {
731     iPtr->assocData = (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable));
732     Tcl_InitHashTable(iPtr->assocData, TCL_STRING_KEYS);
733     }
734     hPtr = Tcl_CreateHashEntry(iPtr->assocData, name, &new);
735     if (new == 0) {
736     dPtr = (AssocData *) Tcl_GetHashValue(hPtr);
737     } else {
738     dPtr = (AssocData *) ckalloc(sizeof(AssocData));
739     }
740     dPtr->proc = proc;
741     dPtr->clientData = clientData;
742    
743     Tcl_SetHashValue(hPtr, dPtr);
744     }
745    
746     /*
747     *----------------------------------------------------------------------
748     *
749     * Tcl_DeleteAssocData --
750     *
751     * Deletes a named association of user-specified data with
752     * the specified interpreter.
753     *
754     * Results:
755     * None.
756     *
757     * Side effects:
758     * Deletes the association.
759     *
760     *----------------------------------------------------------------------
761     */
762    
763     void
764     Tcl_DeleteAssocData(interp, name)
765     Tcl_Interp *interp; /* Interpreter to associate with. */
766     char *name; /* Name of association. */
767     {
768     Interp *iPtr = (Interp *) interp;
769     AssocData *dPtr;
770     Tcl_HashEntry *hPtr;
771    
772     if (iPtr->assocData == (Tcl_HashTable *) NULL) {
773     return;
774     }
775     hPtr = Tcl_FindHashEntry(iPtr->assocData, name);
776     if (hPtr == (Tcl_HashEntry *) NULL) {
777     return;
778     }
779     dPtr = (AssocData *) Tcl_GetHashValue(hPtr);
780     if (dPtr->proc != NULL) {
781     (dPtr->proc) (dPtr->clientData, interp);
782     }
783     ckfree((char *) dPtr);
784     Tcl_DeleteHashEntry(hPtr);
785     }
786    
787     /*
788     *----------------------------------------------------------------------
789     *
790     * Tcl_GetAssocData --
791     *
792     * Returns the client data associated with this name in the
793     * specified interpreter.
794     *
795     * Results:
796     * The client data in the AssocData record denoted by the named
797     * association, or NULL.
798     *
799     * Side effects:
800     * None.
801     *
802     *----------------------------------------------------------------------
803     */
804    
805     ClientData
806     Tcl_GetAssocData(interp, name, procPtr)
807     Tcl_Interp *interp; /* Interpreter associated with. */
808     char *name; /* Name of association. */
809     Tcl_InterpDeleteProc **procPtr; /* Pointer to place to store address
810     * of current deletion callback. */
811     {
812     Interp *iPtr = (Interp *) interp;
813     AssocData *dPtr;
814     Tcl_HashEntry *hPtr;
815    
816     if (iPtr->assocData == (Tcl_HashTable *) NULL) {
817     return (ClientData) NULL;
818     }
819     hPtr = Tcl_FindHashEntry(iPtr->assocData, name);
820     if (hPtr == (Tcl_HashEntry *) NULL) {
821     return (ClientData) NULL;
822     }
823     dPtr = (AssocData *) Tcl_GetHashValue(hPtr);
824     if (procPtr != (Tcl_InterpDeleteProc **) NULL) {
825     *procPtr = dPtr->proc;
826     }
827     return dPtr->clientData;
828     }
829    
830     /*
831     *----------------------------------------------------------------------
832     *
833     * Tcl_InterpDeleted --
834     *
835     * Returns nonzero if the interpreter has been deleted with a call
836     * to Tcl_DeleteInterp.
837     *
838     * Results:
839     * Nonzero if the interpreter is deleted, zero otherwise.
840     *
841     * Side effects:
842     * None.
843     *
844     *----------------------------------------------------------------------
845     */
846    
847     int
848     Tcl_InterpDeleted(interp)
849     Tcl_Interp *interp;
850     {
851     return (((Interp *) interp)->flags & DELETED) ? 1 : 0;
852     }
853    
854     /*
855     *----------------------------------------------------------------------
856     *
857     * Tcl_DeleteInterp --
858     *
859     * Ensures that the interpreter will be deleted eventually. If there
860     * are no Tcl_Preserve calls in effect for this interpreter, it is
861     * deleted immediately, otherwise the interpreter is deleted when
862     * the last Tcl_Preserve is matched by a call to Tcl_Release. In either
863     * case, the procedure runs the currently registered deletion callbacks.
864     *
865     * Results:
866     * None.
867     *
868     * Side effects:
869     * The interpreter is marked as deleted. The caller may still use it
870     * safely if there are calls to Tcl_Preserve in effect for the
871     * interpreter, but further calls to Tcl_Eval etc in this interpreter
872     * will fail.
873     *
874     *----------------------------------------------------------------------
875     */
876    
877     void
878     Tcl_DeleteInterp(interp)
879     Tcl_Interp *interp; /* Token for command interpreter (returned
880     * by a previous call to Tcl_CreateInterp). */
881     {
882     Interp *iPtr = (Interp *) interp;
883    
884     /*
885     * If the interpreter has already been marked deleted, just punt.
886     */
887    
888     if (iPtr->flags & DELETED) {
889     return;
890     }
891    
892     /*
893     * Mark the interpreter as deleted. No further evals will be allowed.
894     */
895    
896     iPtr->flags |= DELETED;
897    
898     /*
899     * Ensure that the interpreter is eventually deleted.
900     */
901    
902     Tcl_EventuallyFree((ClientData) interp,
903     (Tcl_FreeProc *) DeleteInterpProc);
904     }
905    
906     /*
907     *----------------------------------------------------------------------
908     *
909     * DeleteInterpProc --
910     *
911     * Helper procedure to delete an interpreter. This procedure is
912     * called when the last call to Tcl_Preserve on this interpreter
913     * is matched by a call to Tcl_Release. The procedure cleans up
914     * all resources used in the interpreter and calls all currently
915     * registered interpreter deletion callbacks.
916     *
917     * Results:
918     * None.
919     *
920     * Side effects:
921     * Whatever the interpreter deletion callbacks do. Frees resources
922     * used by the interpreter.
923     *
924     *----------------------------------------------------------------------
925     */
926    
927     static void
928     DeleteInterpProc(interp)
929     Tcl_Interp *interp; /* Interpreter to delete. */
930     {
931     Interp *iPtr = (Interp *) interp;
932     Tcl_HashEntry *hPtr;
933     Tcl_HashSearch search;
934     Tcl_HashTable *hTablePtr;
935     ResolverScheme *resPtr, *nextResPtr;
936    
937     /*
938     * Punt if there is an error in the Tcl_Release/Tcl_Preserve matchup.
939     */
940    
941     if (iPtr->numLevels > 0) {
942     panic("DeleteInterpProc called with active evals");
943     }
944    
945     /*
946     * The interpreter should already be marked deleted; otherwise how
947     * did we get here?
948     */
949    
950     if (!(iPtr->flags & DELETED)) {
951     panic("DeleteInterpProc called on interpreter not marked deleted");
952     }
953    
954     TclHandleFree(iPtr->handle);
955    
956     /*
957     * Dismantle everything in the global namespace except for the
958     * "errorInfo" and "errorCode" variables. These remain until the
959     * namespace is actually destroyed, in case any errors occur.
960     *
961     * Dismantle the namespace here, before we clear the assocData. If any
962     * background errors occur here, they will be deleted below.
963     */
964    
965     TclTeardownNamespace(iPtr->globalNsPtr);
966    
967     /*
968     * Delete all the hidden commands.
969     */
970    
971     hTablePtr = iPtr->hiddenCmdTablePtr;
972     if (hTablePtr != NULL) {
973     /*
974     * Non-pernicious deletion. The deletion callbacks will not be
975     * allowed to create any new hidden or non-hidden commands.
976     * Tcl_DeleteCommandFromToken() will remove the entry from the
977     * hiddenCmdTablePtr.
978     */
979    
980     hPtr = Tcl_FirstHashEntry(hTablePtr, &search);
981     for ( ; hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
982     Tcl_DeleteCommandFromToken(interp,
983     (Tcl_Command) Tcl_GetHashValue(hPtr));
984     }
985     Tcl_DeleteHashTable(hTablePtr);
986     ckfree((char *) hTablePtr);
987     }
988     /*
989     * Tear down the math function table.
990     */
991    
992     for (hPtr = Tcl_FirstHashEntry(&iPtr->mathFuncTable, &search);
993     hPtr != NULL;
994     hPtr = Tcl_NextHashEntry(&search)) {
995     ckfree((char *) Tcl_GetHashValue(hPtr));
996     }
997     Tcl_DeleteHashTable(&iPtr->mathFuncTable);
998    
999     /*
1000     * Invoke deletion callbacks; note that a callback can create new
1001     * callbacks, so we iterate.
1002     */
1003    
1004     while (iPtr->assocData != (Tcl_HashTable *) NULL) {
1005     AssocData *dPtr;
1006    
1007     hTablePtr = iPtr->assocData;
1008     iPtr->assocData = (Tcl_HashTable *) NULL;
1009     for (hPtr = Tcl_FirstHashEntry(hTablePtr, &search);
1010     hPtr != NULL;
1011     hPtr = Tcl_FirstHashEntry(hTablePtr, &search)) {
1012     dPtr = (AssocData *) Tcl_GetHashValue(hPtr);
1013     Tcl_DeleteHashEntry(hPtr);
1014     if (dPtr->proc != NULL) {
1015     (*dPtr->proc)(dPtr->clientData, interp);
1016     }
1017     ckfree((char *) dPtr);
1018     }
1019     Tcl_DeleteHashTable(hTablePtr);
1020     ckfree((char *) hTablePtr);
1021     }
1022    
1023     /*
1024     * Finish deleting the global namespace.
1025     */
1026    
1027     Tcl_DeleteNamespace((Tcl_Namespace *) iPtr->globalNsPtr);
1028    
1029     /*
1030     * Free up the result *after* deleting variables, since variable
1031     * deletion could have transferred ownership of the result string
1032     * to Tcl.
1033     */
1034    
1035     Tcl_FreeResult(interp);
1036     interp->result = NULL;
1037     Tcl_DecrRefCount(iPtr->objResultPtr);
1038     iPtr->objResultPtr = NULL;
1039     if (iPtr->errorInfo != NULL) {
1040     ckfree(iPtr->errorInfo);
1041     iPtr->errorInfo = NULL;
1042     }
1043     if (iPtr->errorCode != NULL) {
1044     ckfree(iPtr->errorCode);
1045     iPtr->errorCode = NULL;
1046     }
1047     if (iPtr->appendResult != NULL) {
1048     ckfree(iPtr->appendResult);
1049     iPtr->appendResult = NULL;
1050     }
1051     TclFreePackageInfo(iPtr);
1052     while (iPtr->tracePtr != NULL) {
1053     Trace *nextPtr = iPtr->tracePtr->nextPtr;
1054    
1055     ckfree((char *) iPtr->tracePtr);
1056     iPtr->tracePtr = nextPtr;
1057     }
1058     if (iPtr->execEnvPtr != NULL) {
1059     TclDeleteExecEnv(iPtr->execEnvPtr);
1060     }
1061     Tcl_DecrRefCount(iPtr->emptyObjPtr);
1062     iPtr->emptyObjPtr = NULL;
1063    
1064     resPtr = iPtr->resolverPtr;
1065     while (resPtr) {
1066     nextResPtr = resPtr->nextPtr;
1067     ckfree(resPtr->name);
1068     ckfree((char *) resPtr);
1069     resPtr = nextResPtr;
1070     }
1071    
1072     /*
1073     * Free up literal objects created for scripts compiled by the
1074     * interpreter.
1075     */
1076    
1077     TclDeleteLiteralTable(interp, &(iPtr->literalTable));
1078     ckfree((char *) iPtr);
1079     }
1080    
1081     /*
1082     *---------------------------------------------------------------------------
1083     *
1084     * Tcl_HideCommand --
1085     *
1086     * Makes a command hidden so that it cannot be invoked from within
1087     * an interpreter, only from within an ancestor.
1088     *
1089     * Results:
1090     * A standard Tcl result; also leaves a message in the interp's result
1091     * if an error occurs.
1092     *
1093     * Side effects:
1094     * Removes a command from the command table and create an entry
1095     * into the hidden command table under the specified token name.
1096     *
1097     *---------------------------------------------------------------------------
1098     */
1099    
1100     int
1101     Tcl_HideCommand(interp, cmdName, hiddenCmdToken)
1102     Tcl_Interp *interp; /* Interpreter in which to hide command. */
1103     char *cmdName; /* Name of command to hide. */
1104     char *hiddenCmdToken; /* Token name of the to-be-hidden command. */
1105     {
1106     Interp *iPtr = (Interp *) interp;
1107     Tcl_Command cmd;
1108     Command *cmdPtr;
1109     Tcl_HashTable *hiddenCmdTablePtr;
1110     Tcl_HashEntry *hPtr;
1111     int new;
1112    
1113     if (iPtr->flags & DELETED) {
1114    
1115     /*
1116     * The interpreter is being deleted. Do not create any new
1117     * structures, because it is not safe to modify the interpreter.
1118     */
1119    
1120     return TCL_ERROR;
1121     }
1122    
1123     /*
1124     * Disallow hiding of commands that are currently in a namespace or
1125     * renaming (as part of hiding) into a namespace.
1126     *
1127     * (because the current implementation with a single global table
1128     * and the needed uniqueness of names cause problems with namespaces)
1129     *
1130     * we don't need to check for "::" in cmdName because the real check is
1131     * on the nsPtr below.
1132     *
1133     * hiddenCmdToken is just a string which is not interpreted in any way.
1134     * It may contain :: but the string is not interpreted as a namespace
1135     * qualifier command name. Thus, hiding foo::bar to foo::bar and then
1136     * trying to expose or invoke ::foo::bar will NOT work; but if the
1137     * application always uses the same strings it will get consistent
1138     * behaviour.
1139     *
1140     * But as we currently limit ourselves to the global namespace only
1141     * for the source, in order to avoid potential confusion,
1142     * lets prevent "::" in the token too. --dl
1143     */
1144    
1145     if (strstr(hiddenCmdToken, "::") != NULL) {
1146     Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
1147     "cannot use namespace qualifiers as hidden command",
1148     "token (rename)", (char *) NULL);
1149     return TCL_ERROR;
1150     }
1151    
1152     /*
1153     * Find the command to hide. An error is returned if cmdName can't
1154     * be found. Look up the command only from the global namespace.
1155     * Full path of the command must be given if using namespaces.
1156     */
1157    
1158     cmd = Tcl_FindCommand(interp, cmdName, (Tcl_Namespace *) NULL,
1159     /*flags*/ TCL_LEAVE_ERR_MSG | TCL_GLOBAL_ONLY);
1160     if (cmd == (Tcl_Command) NULL) {
1161     return TCL_ERROR;
1162     }
1163     cmdPtr = (Command *) cmd;
1164    
1165     /*
1166     * Check that the command is really in global namespace
1167     */
1168    
1169     if ( cmdPtr->nsPtr != iPtr->globalNsPtr ) {
1170     Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
1171     "can only hide global namespace commands",
1172     " (use rename then hide)", (char *) NULL);
1173     return TCL_ERROR;
1174     }
1175    
1176     /*
1177     * Initialize the hidden command table if necessary.
1178     */
1179    
1180     hiddenCmdTablePtr = iPtr->hiddenCmdTablePtr;
1181     if (hiddenCmdTablePtr == NULL) {
1182     hiddenCmdTablePtr = (Tcl_HashTable *)
1183     ckalloc((unsigned) sizeof(Tcl_HashTable));
1184     Tcl_InitHashTable(hiddenCmdTablePtr, TCL_STRING_KEYS);
1185     iPtr->hiddenCmdTablePtr = hiddenCmdTablePtr;
1186     }
1187    
1188     /*
1189     * It is an error to move an exposed command to a hidden command with
1190     * hiddenCmdToken if a hidden command with the name hiddenCmdToken already
1191     * exists.
1192     */
1193    
1194     hPtr = Tcl_CreateHashEntry(hiddenCmdTablePtr, hiddenCmdToken, &new);
1195     if (!new) {
1196     Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
1197     "hidden command named \"", hiddenCmdToken, "\" already exists",
1198     (char *) NULL);
1199     return TCL_ERROR;
1200     }
1201    
1202     /*
1203     * Nb : This code is currently 'like' a rename to a specialy set apart
1204     * name table. Changes here and in TclRenameCommand must
1205     * be kept in synch untill the common parts are actually
1206     * factorized out.
1207     */
1208    
1209     /*
1210     * Remove the hash entry for the command from the interpreter command
1211     * table. This is like deleting the command, so bump its command epoch;
1212     * this invalidates any cached references that point to the command.
1213     */
1214    
1215     if (cmdPtr->hPtr != NULL) {
1216     Tcl_DeleteHashEntry(cmdPtr->hPtr);
1217     cmdPtr->hPtr = (Tcl_HashEntry *) NULL;
1218     cmdPtr->cmdEpoch++;
1219     }
1220    
1221     /*
1222     * Now link the hash table entry with the command structure.
1223     * We ensured above that the nsPtr was right.
1224     */
1225    
1226     cmdPtr->hPtr = hPtr;
1227     Tcl_SetHashValue(hPtr, (ClientData) cmdPtr);
1228    
1229     /*
1230     * If the command being hidden has a compile procedure, increment the
1231     * interpreter's compileEpoch to invalidate its compiled code. This
1232     * makes sure that we don't later try to execute old code compiled with
1233     * command-specific (i.e., inline) bytecodes for the now-hidden
1234     * command. This field is checked in Tcl_EvalObj and ObjInterpProc,
1235     * and code whose compilation epoch doesn't match is recompiled.
1236     */
1237    
1238     if (cmdPtr->compileProc != NULL) {
1239     iPtr->compileEpoch++;
1240     }
1241     return TCL_OK;
1242     }
1243    
1244     /*
1245     *----------------------------------------------------------------------
1246     *
1247     * Tcl_ExposeCommand --
1248     *
1249     * Makes a previously hidden command callable from inside the
1250     * interpreter instead of only by its ancestors.
1251     *
1252     * Results:
1253     * A standard Tcl result. If an error occurs, a message is left
1254     * in the interp's result.
1255     *
1256     * Side effects:
1257     * Moves commands from one hash table to another.
1258     *
1259     *----------------------------------------------------------------------
1260     */
1261    
1262     int
1263     Tcl_ExposeCommand(interp, hiddenCmdToken, cmdName)
1264     Tcl_Interp *interp; /* Interpreter in which to make command
1265     * callable. */
1266     char *hiddenCmdToken; /* Name of hidden command. */
1267     char *cmdName; /* Name of to-be-exposed command. */
1268     {
1269     Interp *iPtr = (Interp *) interp;
1270     Command *cmdPtr;
1271     Namespace *nsPtr;
1272     Tcl_HashEntry *hPtr;
1273     Tcl_HashTable *hiddenCmdTablePtr;
1274     int new;
1275    
1276     if (iPtr->flags & DELETED) {
1277     /*
1278     * The interpreter is being deleted. Do not create any new
1279     * structures, because it is not safe to modify the interpreter.
1280     */
1281    
1282     return TCL_ERROR;
1283     }
1284    
1285     /*
1286     * Check that we have a regular name for the command
1287     * (that the user is not trying to do an expose and a rename
1288     * (to another namespace) at the same time)
1289     */
1290    
1291     if (strstr(cmdName, "::") != NULL) {
1292     Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
1293     "can not expose to a namespace ",
1294     "(use expose to toplevel, then rename)",
1295     (char *) NULL);
1296     return TCL_ERROR;
1297     }
1298    
1299     /*
1300     * Get the command from the hidden command table:
1301     */
1302    
1303     hPtr = NULL;
1304     hiddenCmdTablePtr = iPtr->hiddenCmdTablePtr;
1305     if (hiddenCmdTablePtr != NULL) {
1306     hPtr = Tcl_FindHashEntry(hiddenCmdTablePtr, hiddenCmdToken);
1307     }
1308     if (hPtr == (Tcl_HashEntry *) NULL) {
1309     Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
1310     "unknown hidden command \"", hiddenCmdToken,
1311     "\"", (char *) NULL);
1312     return TCL_ERROR;
1313     }
1314     cmdPtr = (Command *) Tcl_GetHashValue(hPtr);
1315    
1316    
1317     /*
1318     * Check that we have a true global namespace
1319     * command (enforced by Tcl_HideCommand() but let's double
1320     * check. (If it was not, we would not really know how to
1321     * handle it).
1322     */
1323     if ( cmdPtr->nsPtr != iPtr->globalNsPtr ) {
1324     /*
1325     * This case is theoritically impossible,
1326     * we might rather panic() than 'nicely' erroring out ?
1327     */
1328     Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
1329     "trying to expose a non global command name space command",
1330     (char *) NULL);
1331     return TCL_ERROR;
1332     }
1333    
1334     /* This is the global table */
1335     nsPtr = cmdPtr->nsPtr;
1336    
1337     /*
1338     * It is an error to overwrite an existing exposed command as a result
1339     * of exposing a previously hidden command.
1340     */
1341    
1342     hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, cmdName, &new);
1343     if (!new) {
1344     Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
1345     "exposed command \"", cmdName,
1346     "\" already exists", (char *) NULL);
1347     return TCL_ERROR;
1348     }
1349    
1350     /*
1351     * Remove the hash entry for the command from the interpreter hidden
1352     * command table.
1353     */
1354    
1355     if (cmdPtr->hPtr != NULL) {
1356     Tcl_DeleteHashEntry(cmdPtr->hPtr);
1357     cmdPtr->hPtr = NULL;
1358     }
1359    
1360     /*
1361     * Now link the hash table entry with the command structure.
1362     * This is like creating a new command, so deal with any shadowing
1363     * of commands in the global namespace.
1364     */
1365    
1366     cmdPtr->hPtr = hPtr;
1367    
1368     Tcl_SetHashValue(hPtr, (ClientData) cmdPtr);
1369    
1370     /*
1371     * Not needed as we are only in the global namespace
1372     * (but would be needed again if we supported namespace command hiding)
1373     *
1374     * TclResetShadowedCmdRefs(interp, cmdPtr);
1375     */
1376    
1377    
1378     /*
1379     * If the command being exposed has a compile procedure, increment
1380     * interpreter's compileEpoch to invalidate its compiled code. This
1381     * makes sure that we don't later try to execute old code compiled
1382     * assuming the command is hidden. This field is checked in Tcl_EvalObj
1383     * and ObjInterpProc, and code whose compilation epoch doesn't match is
1384     * recompiled.
1385     */
1386    
1387     if (cmdPtr->compileProc != NULL) {
1388     iPtr->compileEpoch++;
1389     }
1390     return TCL_OK;
1391     }
1392    
1393     /*
1394     *----------------------------------------------------------------------
1395     *
1396     * Tcl_CreateCommand --
1397     *
1398     * Define a new command in a command table.
1399     *
1400     * Results:
1401     * The return value is a token for the command, which can
1402     * be used in future calls to Tcl_GetCommandName.
1403     *
1404     * Side effects:
1405     * If a command named cmdName already exists for interp, it is deleted.
1406     * In the future, when cmdName is seen as the name of a command by
1407     * Tcl_Eval, proc will be called. To support the bytecode interpreter,
1408     * the command is created with a wrapper Tcl_ObjCmdProc
1409     * (TclInvokeStringCommand) that eventially calls proc. When the
1410     * command is deleted from the table, deleteProc will be called.
1411     * See the manual entry for details on the calling sequence.
1412     *
1413     *----------------------------------------------------------------------
1414     */
1415    
1416     Tcl_Command
1417     Tcl_CreateCommand(interp, cmdName, proc, clientData, deleteProc)
1418     Tcl_Interp *interp; /* Token for command interpreter returned by
1419     * a previous call to Tcl_CreateInterp. */
1420     char *cmdName; /* Name of command. If it contains namespace
1421     * qualifiers, the new command is put in the
1422     * specified namespace; otherwise it is put
1423     * in the global namespace. */
1424     Tcl_CmdProc *proc; /* Procedure to associate with cmdName. */
1425     ClientData clientData; /* Arbitrary value passed to string proc. */
1426     Tcl_CmdDeleteProc *deleteProc;
1427     /* If not NULL, gives a procedure to call
1428     * when this command is deleted. */
1429     {
1430     Interp *iPtr = (Interp *) interp;
1431     ImportRef *oldRefPtr = NULL;
1432     Namespace *nsPtr, *dummy1, *dummy2;
1433     Command *cmdPtr, *refCmdPtr;
1434     Tcl_HashEntry *hPtr;
1435     char *tail;
1436     int new;
1437     ImportedCmdData *dataPtr;
1438    
1439     if (iPtr->flags & DELETED) {
1440     /*
1441     * The interpreter is being deleted. Don't create any new
1442     * commands; it's not safe to muck with the interpreter anymore.
1443     */
1444    
1445     return (Tcl_Command) NULL;
1446     }
1447    
1448     /*
1449     * Determine where the command should reside. If its name contains
1450     * namespace qualifiers, we put it in the specified namespace;
1451     * otherwise, we always put it in the global namespace.
1452     */
1453    
1454     if (strstr(cmdName, "::") != NULL) {
1455     TclGetNamespaceForQualName(interp, cmdName, (Namespace *) NULL,
1456     CREATE_NS_IF_UNKNOWN, &nsPtr, &dummy1, &dummy2, &tail);
1457     if ((nsPtr == NULL) || (tail == NULL)) {
1458     return (Tcl_Command) NULL;
1459     }
1460     } else {
1461     nsPtr = iPtr->globalNsPtr;
1462     tail = cmdName;
1463     }
1464    
1465     hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, tail, &new);
1466     if (!new) {
1467     /*
1468     * Command already exists. Delete the old one.
1469     * Be careful to preserve any existing import links so we can
1470     * restore them down below. That way, you can redefine a
1471     * command and its import status will remain intact.
1472     */
1473    
1474     cmdPtr = (Command *) Tcl_GetHashValue(hPtr);
1475     oldRefPtr = cmdPtr->importRefPtr;
1476     cmdPtr->importRefPtr = NULL;
1477    
1478     Tcl_DeleteCommandFromToken(interp, (Tcl_Command) cmdPtr);
1479     hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, tail, &new);
1480     if (!new) {
1481     /*
1482     * If the deletion callback recreated the command, just throw
1483     * away the new command (if we try to delete it again, we
1484     * could get stuck in an infinite loop).
1485     */
1486    
1487     ckfree((char*) Tcl_GetHashValue(hPtr));
1488     }
1489     }
1490     cmdPtr = (Command *) ckalloc(sizeof(Command));
1491     Tcl_SetHashValue(hPtr, cmdPtr);
1492     cmdPtr->hPtr = hPtr;
1493     cmdPtr->nsPtr = nsPtr;
1494     cmdPtr->refCount = 1;
1495     cmdPtr->cmdEpoch = 0;
1496     cmdPtr->compileProc = (CompileProc *) NULL;
1497     cmdPtr->objProc = TclInvokeStringCommand;
1498     cmdPtr->objClientData = (ClientData) cmdPtr;
1499     cmdPtr->proc = proc;
1500     cmdPtr->clientData = clientData;
1501     cmdPtr->deleteProc = deleteProc;
1502     cmdPtr->deleteData = clientData;
1503     cmdPtr->deleted = 0;
1504     cmdPtr->importRefPtr = NULL;
1505    
1506     /*
1507     * Plug in any existing import references found above. Be sure
1508     * to update all of these references to point to the new command.
1509     */
1510    
1511     if (oldRefPtr != NULL) {
1512     cmdPtr->importRefPtr = oldRefPtr;
1513     while (oldRefPtr != NULL) {
1514     refCmdPtr = oldRefPtr->importedCmdPtr;
1515     dataPtr = (ImportedCmdData*)refCmdPtr->objClientData;
1516     dataPtr->realCmdPtr = cmdPtr;
1517     oldRefPtr = oldRefPtr->nextPtr;
1518     }
1519     }
1520    
1521     /*
1522     * We just created a command, so in its namespace and all of its parent
1523     * namespaces, it may shadow global commands with the same name. If any
1524     * shadowed commands are found, invalidate all cached command references
1525     * in the affected namespaces.
1526     */
1527    
1528     TclResetShadowedCmdRefs(interp, cmdPtr);
1529     return (Tcl_Command) cmdPtr;
1530     }
1531    
1532     /*
1533     *----------------------------------------------------------------------
1534     *
1535     * Tcl_CreateObjCommand --
1536     *
1537     * Define a new object-based command in a command table.
1538     *
1539     * Results:
1540     * The return value is a token for the command, which can
1541     * be used in future calls to Tcl_GetCommandName.
1542     *
1543     * Side effects:
1544     * If no command named "cmdName" already exists for interp, one is
1545     * created. Otherwise, if a command does exist, then if the
1546     * object-based Tcl_ObjCmdProc is TclInvokeStringCommand, we assume
1547     * Tcl_CreateCommand was called previously for the same command and
1548     * just set its Tcl_ObjCmdProc to the argument "proc"; otherwise, we
1549     * delete the old command.
1550     *
1551     * In the future, during bytecode evaluation when "cmdName" is seen as
1552     * the name of a command by Tcl_EvalObj or Tcl_Eval, the object-based
1553     * Tcl_ObjCmdProc proc will be called. When the command is deleted from
1554     * the table, deleteProc will be called. See the manual entry for
1555     * details on the calling sequence.
1556     *
1557     *----------------------------------------------------------------------
1558     */
1559    
1560     Tcl_Command
1561     Tcl_CreateObjCommand(interp, cmdName, proc, clientData, deleteProc)
1562     Tcl_Interp *interp; /* Token for command interpreter (returned
1563     * by previous call to Tcl_CreateInterp). */
1564     char *cmdName; /* Name of command. If it contains namespace
1565     * qualifiers, the new command is put in the
1566     * specified namespace; otherwise it is put
1567     * in the global namespace. */
1568     Tcl_ObjCmdProc *proc; /* Object-based procedure to associate with
1569     * name. */
1570     ClientData clientData; /* Arbitrary value to pass to object
1571     * procedure. */
1572     Tcl_CmdDeleteProc *deleteProc;
1573     /* If not NULL, gives a procedure to call
1574     * when this command is deleted. */
1575     {
1576     Interp *iPtr = (Interp *) interp;
1577     ImportRef *oldRefPtr = NULL;
1578     Namespace *nsPtr, *dummy1, *dummy2;
1579     Command *cmdPtr, *refCmdPtr;
1580     Tcl_HashEntry *hPtr;
1581     char *tail;
1582     int new;
1583     ImportedCmdData *dataPtr;
1584    
1585     if (iPtr->flags & DELETED) {
1586     /*
1587     * The interpreter is being deleted. Don't create any new
1588     * commands; it's not safe to muck with the interpreter anymore.
1589     */
1590    
1591     return (Tcl_Command) NULL;
1592     }
1593    
1594     /*
1595     * Determine where the command should reside. If its name contains
1596     * namespace qualifiers, we put it in the specified namespace;
1597     * otherwise, we always put it in the global namespace.
1598     */
1599    
1600     if (strstr(cmdName, "::") != NULL) {
1601     TclGetNamespaceForQualName(interp, cmdName, (Namespace *) NULL,
1602     CREATE_NS_IF_UNKNOWN, &nsPtr, &dummy1, &dummy2, &tail);
1603     if ((nsPtr == NULL) || (tail == NULL)) {
1604     return (Tcl_Command) NULL;
1605     }
1606     } else {
1607     nsPtr = iPtr->globalNsPtr;
1608     tail = cmdName;
1609     }
1610    
1611     hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, tail, &new);
1612     if (!new) {
1613     cmdPtr = (Command *) Tcl_GetHashValue(hPtr);
1614    
1615     /*
1616     * Command already exists. If its object-based Tcl_ObjCmdProc is
1617     * TclInvokeStringCommand, we just set its Tcl_ObjCmdProc to the
1618     * argument "proc". Otherwise, we delete the old command.
1619     */
1620    
1621     if (cmdPtr->objProc == TclInvokeStringCommand) {
1622     cmdPtr->objProc = proc;
1623     cmdPtr->objClientData = clientData;
1624     cmdPtr->deleteProc = deleteProc;
1625     cmdPtr->deleteData = clientData;
1626     return (Tcl_Command) cmdPtr;
1627     }
1628    
1629     /*
1630     * Otherwise, we delete the old command. Be careful to preserve
1631     * any existing import links so we can restore them down below.
1632     * That way, you can redefine a command and its import status
1633     * will remain intact.
1634     */
1635    
1636     oldRefPtr = cmdPtr->importRefPtr;
1637     cmdPtr->importRefPtr = NULL;
1638    
1639     Tcl_DeleteCommandFromToken(interp, (Tcl_Command) cmdPtr);
1640     hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, tail, &new);
1641     if (!new) {
1642     /*
1643     * If the deletion callback recreated the command, just throw
1644     * away the new command (if we try to delete it again, we
1645     * could get stuck in an infinite loop).
1646     */
1647    
1648     ckfree((char *) Tcl_GetHashValue(hPtr));
1649     }
1650     }
1651     cmdPtr = (Command *) ckalloc(sizeof(Command));
1652     Tcl_SetHashValue(hPtr, cmdPtr);
1653     cmdPtr->hPtr = hPtr;
1654     cmdPtr->nsPtr = nsPtr;
1655     cmdPtr->refCount = 1;
1656     cmdPtr->cmdEpoch = 0;
1657     cmdPtr->compileProc = (CompileProc *) NULL;
1658     cmdPtr->objProc = proc;
1659     cmdPtr->objClientData = clientData;
1660     cmdPtr->proc = TclInvokeObjectCommand;
1661     cmdPtr->clientData = (ClientData) cmdPtr;
1662     cmdPtr->deleteProc = deleteProc;
1663     cmdPtr->deleteData = clientData;
1664     cmdPtr->deleted = 0;
1665     cmdPtr->importRefPtr = NULL;
1666    
1667     /*
1668     * Plug in any existing import references found above. Be sure
1669     * to update all of these references to point to the new command.
1670     */
1671    
1672     if (oldRefPtr != NULL) {
1673     cmdPtr->importRefPtr = oldRefPtr;
1674     while (oldRefPtr != NULL) {
1675     refCmdPtr = oldRefPtr->importedCmdPtr;
1676     dataPtr = (ImportedCmdData*)refCmdPtr->objClientData;
1677     dataPtr->realCmdPtr = cmdPtr;
1678     oldRefPtr = oldRefPtr->nextPtr;
1679     }
1680     }
1681    
1682     /*
1683     * We just created a command, so in its namespace and all of its parent
1684     * namespaces, it may shadow global commands with the same name. If any
1685     * shadowed commands are found, invalidate all cached command references
1686     * in the affected namespaces.
1687     */
1688    
1689     TclResetShadowedCmdRefs(interp, cmdPtr);
1690     return (Tcl_Command) cmdPtr;
1691     }
1692    
1693     /*
1694     *----------------------------------------------------------------------
1695     *
1696     * TclInvokeStringCommand --
1697     *
1698     * "Wrapper" Tcl_ObjCmdProc used to call an existing string-based
1699     * Tcl_CmdProc if no object-based procedure exists for a command. A
1700     * pointer to this procedure is stored as the Tcl_ObjCmdProc in a
1701     * Command structure. It simply turns around and calls the string
1702     * Tcl_CmdProc in the Command structure.
1703     *
1704     * Results:
1705     * A standard Tcl object result value.
1706     *
1707     * Side effects:
1708     * Besides those side effects of the called Tcl_CmdProc,
1709     * TclInvokeStringCommand allocates and frees storage.
1710     *
1711     *----------------------------------------------------------------------
1712     */
1713    
1714     int
1715     TclInvokeStringCommand(clientData, interp, objc, objv)
1716     ClientData clientData; /* Points to command's Command structure. */
1717     Tcl_Interp *interp; /* Current interpreter. */
1718     register int objc; /* Number of arguments. */
1719     Tcl_Obj *CONST objv[]; /* Argument objects. */
1720     {
1721     register Command *cmdPtr = (Command *) clientData;
1722     register int i;
1723     int result;
1724    
1725     /*
1726     * This procedure generates an argv array for the string arguments. It
1727     * starts out with stack-allocated space but uses dynamically-allocated
1728     * storage if needed.
1729     */
1730    
1731     #define NUM_ARGS 20
1732     char *(argStorage[NUM_ARGS]);
1733     char **argv = argStorage;
1734    
1735     /*
1736     * Create the string argument array "argv". Make sure argv is large
1737     * enough to hold the objc arguments plus 1 extra for the zero
1738     * end-of-argv word.
1739     */
1740    
1741     if ((objc + 1) > NUM_ARGS) {
1742     argv = (char **) ckalloc((unsigned)(objc + 1) * sizeof(char *));
1743     }
1744    
1745     for (i = 0; i < objc; i++) {
1746     argv[i] = Tcl_GetString(objv[i]);
1747     }
1748     argv[objc] = 0;
1749    
1750     /*
1751     * Invoke the command's string-based Tcl_CmdProc.
1752     */
1753    
1754     result = (*cmdPtr->proc)(cmdPtr->clientData, interp, objc, argv);
1755    
1756     /*
1757     * Free the argv array if malloc'ed storage was used.
1758     */
1759    
1760     if (argv != argStorage) {
1761     ckfree((char *) argv);
1762     }
1763     return result;
1764     #undef NUM_ARGS
1765     }
1766    
1767     /*
1768     *----------------------------------------------------------------------
1769     *
1770     * TclInvokeObjectCommand --
1771     *
1772     * "Wrapper" Tcl_CmdProc used to call an existing object-based
1773     * Tcl_ObjCmdProc if no string-based procedure exists for a command.
1774     * A pointer to this procedure is stored as the Tcl_CmdProc in a
1775     * Command structure. It simply turns around and calls the object
1776     * Tcl_ObjCmdProc in the Command structure.
1777     *
1778     * Results:
1779     * A standard Tcl string result value.
1780     *
1781     * Side effects:
1782     * Besides those side effects of the called Tcl_CmdProc,
1783     * TclInvokeStringCommand allocates and frees storage.
1784     *
1785     *----------------------------------------------------------------------
1786     */
1787    
1788     int
1789     TclInvokeObjectCommand(clientData, interp, argc, argv)
1790     ClientData clientData; /* Points to command's Command structure. */
1791     Tcl_Interp *interp; /* Current interpreter. */
1792     int argc; /* Number of arguments. */
1793     register char **argv; /* Argument strings. */
1794     {
1795     Command *cmdPtr = (Command *) clientData;
1796     register Tcl_Obj *objPtr;
1797     register int i;
1798     int length, result;
1799    
1800     /*
1801     * This procedure generates an objv array for object arguments that hold
1802     * the argv strings. It starts out with stack-allocated space but uses
1803     * dynamically-allocated storage if needed.
1804     */
1805    
1806     #define NUM_ARGS 20
1807     Tcl_Obj *(argStorage[NUM_ARGS]);
1808     register Tcl_Obj **objv = argStorage;
1809    
1810     /*
1811     * Create the object argument array "objv". Make sure objv is large
1812     * enough to hold the objc arguments plus 1 extra for the zero
1813     * end-of-objv word.
1814     */
1815    
1816     if ((argc + 1) > NUM_ARGS) {
1817     objv = (Tcl_Obj **)
1818     ckalloc((unsigned)(argc + 1) * sizeof(Tcl_Obj *));
1819     }
1820    
1821     for (i = 0; i < argc; i++) {
1822     length = strlen(argv[i]);
1823     TclNewObj(objPtr);
1824     TclInitStringRep(objPtr, argv[i], length);
1825     Tcl_IncrRefCount(objPtr);
1826     objv[i] = objPtr;
1827     }
1828     objv[argc] = 0;
1829    
1830     /*
1831     * Invoke the command's object-based Tcl_ObjCmdProc.
1832     */
1833    
1834     result = (*cmdPtr->objProc)(cmdPtr->objClientData, interp, argc, objv);
1835    
1836     /*
1837     * Move the interpreter's object result to the string result,
1838     * then reset the object result.
1839     */
1840    
1841     Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)),
1842     TCL_VOLATILE);
1843    
1844     /*
1845     * Decrement the ref counts for the argument objects created above,
1846     * then free the objv array if malloc'ed storage was used.
1847     */
1848    
1849     for (i = 0; i < argc; i++) {
1850     objPtr = objv[i];
1851     Tcl_DecrRefCount(objPtr);
1852     }
1853     if (objv != argStorage) {
1854     ckfree((char *) objv);
1855     }
1856     return result;
1857     #undef NUM_ARGS
1858     }
1859    
1860     /*
1861     *----------------------------------------------------------------------
1862     *
1863     * TclRenameCommand --
1864     *
1865     * Called to give an existing Tcl command a different name. Both the
1866     * old command name and the new command name can have "::" namespace
1867     * qualifiers. If the new command has a different namespace context,
1868     * the command will be moved to that namespace and will execute in
1869     * the context of that new namespace.
1870     *
1871     * If the new command name is NULL or the null string, the command is
1872     * deleted.
1873     *
1874     * Results:
1875     * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong.
1876     *
1877     * Side effects:
1878     * If anything goes wrong, an error message is returned in the
1879     * interpreter's result object.
1880     *
1881     *----------------------------------------------------------------------
1882     */
1883    
1884     int
1885     TclRenameCommand(interp, oldName, newName)
1886     Tcl_Interp *interp; /* Current interpreter. */
1887     char *oldName; /* Existing command name. */
1888     char *newName; /* New command name. */
1889     {
1890     Interp *iPtr = (Interp *) interp;
1891     char *newTail;
1892     Namespace *cmdNsPtr, *newNsPtr, *dummy1, *dummy2;
1893     Tcl_Command cmd;
1894     Command *cmdPtr;
1895     Tcl_HashEntry *hPtr, *oldHPtr;
1896     int new, result;
1897    
1898     /*
1899     * Find the existing command. An error is returned if cmdName can't
1900     * be found.
1901     */
1902    
1903     cmd = Tcl_FindCommand(interp, oldName, (Tcl_Namespace *) NULL,
1904     /*flags*/ 0);
1905     cmdPtr = (Command *) cmd;
1906     if (cmdPtr == NULL) {
1907     Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "can't ",
1908     ((newName == NULL)||(*newName == '\0'))? "delete":"rename",
1909     " \"", oldName, "\": command doesn't exist", (char *) NULL);
1910     return TCL_ERROR;
1911     }
1912     cmdNsPtr = cmdPtr->nsPtr;
1913    
1914     /*
1915     * If the new command name is NULL or empty, delete the command. Do this
1916     * with Tcl_DeleteCommandFromToken, since we already have the command.
1917     */
1918    
1919     if ((newName == NULL) || (*newName == '\0')) {
1920     Tcl_DeleteCommandFromToken(interp, cmd);
1921     return TCL_OK;
1922     }
1923    
1924     /*
1925     * Make sure that the destination command does not already exist.
1926     * The rename operation is like creating a command, so we should
1927     * automatically create the containing namespaces just like
1928     * Tcl_CreateCommand would.
1929     */
1930    
1931     TclGetNamespaceForQualName(interp, newName, (Namespace *) NULL,
1932     CREATE_NS_IF_UNKNOWN, &newNsPtr, &dummy1, &dummy2, &newTail);
1933    
1934     if ((newNsPtr == NULL) || (newTail == NULL)) {
1935     Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
1936     "can't rename to \"", newName, "\": bad command name",
1937     (char *) NULL);
1938     return TCL_ERROR;
1939     }
1940     if (Tcl_FindHashEntry(&newNsPtr->cmdTable, newTail) != NULL) {
1941     Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
1942     "can't rename to \"", newName,
1943     "\": command already exists", (char *) NULL);
1944     return TCL_ERROR;
1945     }
1946    
1947    
1948     /*
1949     * Warning: any changes done in the code here are likely
1950     * to be needed in Tcl_HideCommand() code too.
1951     * (until the common parts are extracted out) --dl
1952     */
1953    
1954     /*
1955     * Put the command in the new namespace so we can check for an alias
1956     * loop. Since we are adding a new command to a namespace, we must
1957     * handle any shadowing of the global commands that this might create.
1958     */
1959    
1960     oldHPtr = cmdPtr->hPtr;
1961     hPtr = Tcl_CreateHashEntry(&newNsPtr->cmdTable, newTail, &new);
1962     Tcl_SetHashValue(hPtr, (ClientData) cmdPtr);
1963     cmdPtr->hPtr = hPtr;
1964     cmdPtr->nsPtr = newNsPtr;
1965     TclResetShadowedCmdRefs(interp, cmdPtr);
1966    
1967     /*
1968     * Now check for an alias loop. If we detect one, put everything back
1969     * the way it was and report the error.
1970     */
1971    
1972     result = TclPreventAliasLoop(interp, interp, (Tcl_Command) cmdPtr);
1973     if (result != TCL_OK) {
1974     Tcl_DeleteHashEntry(cmdPtr->hPtr);
1975     cmdPtr->hPtr = oldHPtr;
1976     cmdPtr->nsPtr = cmdNsPtr;
1977     return result;
1978     }
1979    
1980     /*
1981     * The new command name is okay, so remove the command from its
1982     * current namespace. This is like deleting the command, so bump
1983     * the cmdEpoch to invalidate any cached references to the command.
1984     */
1985    
1986     Tcl_DeleteHashEntry(oldHPtr);
1987     cmdPtr->cmdEpoch++;
1988    
1989     /*
1990     * If the command being renamed has a compile procedure, increment the
1991     * interpreter's compileEpoch to invalidate its compiled code. This
1992     * makes sure that we don't later try to execute old code compiled for
1993     * the now-renamed command.
1994     */
1995    
1996     if (cmdPtr->compileProc != NULL) {
1997     iPtr->compileEpoch++;
1998     }
1999    
2000     return TCL_OK;
2001     }
2002    
2003     /*
2004     *----------------------------------------------------------------------
2005     *
2006     * Tcl_SetCommandInfo --
2007     *
2008     * Modifies various information about a Tcl command. Note that
2009     * this procedure will not change a command's namespace; use
2010     * Tcl_RenameCommand to do that. Also, the isNativeObjectProc
2011     * member of *infoPtr is ignored.
2012     *
2013     * Results:
2014     * If cmdName exists in interp, then the information at *infoPtr
2015     * is stored with the command in place of the current information
2016     * and 1 is returned. If the command doesn't exist then 0 is
2017     * returned.
2018     *
2019     * Side effects:
2020     * None.
2021     *
2022     *----------------------------------------------------------------------
2023     */
2024    
2025     int
2026     Tcl_SetCommandInfo(interp, cmdName, infoPtr)
2027     Tcl_Interp *interp; /* Interpreter in which to look
2028     * for command. */
2029     char *cmdName; /* Name of desired command. */
2030     Tcl_CmdInfo *infoPtr; /* Where to find information
2031     * to store in the command. */
2032     {
2033     Tcl_Command cmd;
2034     Command *cmdPtr;
2035    
2036     cmd = Tcl_FindCommand(interp, cmdName, (Tcl_Namespace *) NULL,
2037     /*flags*/ 0);
2038     if (cmd == (Tcl_Command) NULL) {
2039     return 0;
2040     }
2041    
2042     /*
2043     * The isNativeObjectProc and nsPtr members of *infoPtr are ignored.
2044     */
2045    
2046     cmdPtr = (Command *) cmd;
2047     cmdPtr->proc = infoPtr->proc;
2048     cmdPtr->clientData = infoPtr->clientData;
2049     if (infoPtr->objProc == (Tcl_ObjCmdProc *) NULL) {
2050     cmdPtr->objProc = TclInvokeStringCommand;
2051     cmdPtr->objClientData = (ClientData) cmdPtr;
2052     } else {
2053     cmdPtr->objProc = infoPtr->objProc;
2054     cmdPtr->objClientData = infoPtr->objClientData;
2055     }
2056     cmdPtr->deleteProc = infoPtr->deleteProc;
2057     cmdPtr->deleteData = infoPtr->deleteData;
2058     return 1;
2059     }
2060    
2061     /*
2062     *----------------------------------------------------------------------
2063     *
2064     * Tcl_GetCommandInfo --
2065     *
2066     * Returns various information about a Tcl command.
2067     *
2068     * Results:
2069     * If cmdName exists in interp, then *infoPtr is modified to
2070     * hold information about cmdName and 1 is returned. If the
2071     * command doesn't exist then 0 is returned and *infoPtr isn't
2072     * modified.
2073     *
2074     * Side effects:
2075     * None.
2076     *
2077     *----------------------------------------------------------------------
2078     */
2079    
2080     int
2081     Tcl_GetCommandInfo(interp, cmdName, infoPtr)
2082     Tcl_Interp *interp; /* Interpreter in which to look
2083     * for command. */
2084     char *cmdName; /* Name of desired command. */
2085     Tcl_CmdInfo *infoPtr; /* Where to store information about
2086     * command. */
2087     {
2088     Tcl_Command cmd;
2089     Command *cmdPtr;
2090    
2091     cmd = Tcl_FindCommand(interp, cmdName, (Tcl_Namespace *) NULL,
2092     /*flags*/ 0);
2093     if (cmd == (Tcl_Command) NULL) {
2094     return 0;
2095     }
2096    
2097     /*
2098     * Set isNativeObjectProc 1 if objProc was registered by a call to
2099     * Tcl_CreateObjCommand. Otherwise set it to 0.
2100     */
2101    
2102     cmdPtr = (Command *) cmd;
2103     infoPtr->isNativeObjectProc =
2104     (cmdPtr->objProc != TclInvokeStringCommand);
2105     infoPtr->objProc = cmdPtr->objProc;
2106     infoPtr->objClientData = cmdPtr->objClientData;
2107     infoPtr->proc = cmdPtr->proc;
2108     infoPtr->clientData = cmdPtr->clientData;
2109     infoPtr->deleteProc = cmdPtr->deleteProc;
2110     infoPtr->deleteData = cmdPtr->deleteData;
2111     infoPtr->namespacePtr = (Tcl_Namespace *) cmdPtr->nsPtr;
2112     return 1;
2113     }
2114    
2115     /*
2116     *----------------------------------------------------------------------
2117     *
2118     * Tcl_GetCommandName --
2119     *
2120     * Given a token returned by Tcl_CreateCommand, this procedure
2121     * returns the current name of the command (which may have changed
2122     * due to renaming).
2123     *
2124     * Results:
2125     * The return value is the name of the given command.
2126     *
2127     * Side effects:
2128     * None.
2129     *
2130     *----------------------------------------------------------------------
2131     */
2132    
2133     char *
2134     Tcl_GetCommandName(interp, command)
2135     Tcl_Interp *interp; /* Interpreter containing the command. */
2136     Tcl_Command command; /* Token for command returned by a previous
2137     * call to Tcl_CreateCommand. The command
2138     * must not have been deleted. */
2139     {
2140     Command *cmdPtr = (Command *) command;
2141    
2142     if ((cmdPtr == NULL) || (cmdPtr->hPtr == NULL)) {
2143    
2144     /*
2145     * This should only happen if command was "created" after the
2146     * interpreter began to be deleted, so there isn't really any
2147     * command. Just return an empty string.
2148     */
2149    
2150     return "";
2151     }
2152     return Tcl_GetHashKey(cmdPtr->hPtr->tablePtr, cmdPtr->hPtr);
2153     }
2154    
2155     /*
2156     *----------------------------------------------------------------------
2157     *
2158     * Tcl_GetCommandFullName --
2159     *
2160     * Given a token returned by, e.g., Tcl_CreateCommand or
2161     * Tcl_FindCommand, this procedure appends to an object the command's
2162     * full name, qualified by a sequence of parent namespace names. The
2163     * command's fully-qualified name may have changed due to renaming.
2164     *
2165     * Results:
2166     * None.
2167     *
2168     * Side effects:
2169     * The command's fully-qualified name is appended to the string
2170     * representation of objPtr.
2171     *
2172     *----------------------------------------------------------------------
2173     */
2174    
2175     void
2176     Tcl_GetCommandFullName(interp, command, objPtr)
2177     Tcl_Interp *interp; /* Interpreter containing the command. */
2178     Tcl_Command command; /* Token for command returned by a previous
2179     * call to Tcl_CreateCommand. The command
2180     * must not have been deleted. */
2181     Tcl_Obj *objPtr; /* Points to the object onto which the
2182     * command's full name is appended. */
2183    
2184     {
2185     Interp *iPtr = (Interp *) interp;
2186     register Command *cmdPtr = (Command *) command;
2187     char *name;
2188    
2189     /*
2190     * Add the full name of the containing namespace, followed by the "::"
2191     * separator, and the command name.
2192     */
2193    
2194     if (cmdPtr != NULL) {
2195     if (cmdPtr->nsPtr != NULL) {
2196     Tcl_AppendToObj(objPtr, cmdPtr->nsPtr->fullName, -1);
2197     if (cmdPtr->nsPtr != iPtr->globalNsPtr) {
2198     Tcl_AppendToObj(objPtr, "::", 2);
2199     }
2200     }
2201     if (cmdPtr->hPtr != NULL) {
2202     name = Tcl_GetHashKey(cmdPtr->hPtr->tablePtr, cmdPtr->hPtr);
2203     Tcl_AppendToObj(objPtr, name, -1);
2204     }
2205     }
2206     }
2207    
2208     /*
2209     *----------------------------------------------------------------------
2210     *
2211     * Tcl_DeleteCommand --
2212     *
2213     * Remove the given command from the given interpreter.
2214     *
2215     * Results:
2216     * 0 is returned if the command was deleted successfully.
2217     * -1 is returned if there didn't exist a command by that name.
2218     *
2219     * Side effects:
2220     * cmdName will no longer be recognized as a valid command for
2221     * interp.
2222     *
2223     *----------------------------------------------------------------------
2224     */
2225    
2226     int
2227     Tcl_DeleteCommand(interp, cmdName)
2228     Tcl_Interp *interp; /* Token for command interpreter (returned
2229     * by a previous Tcl_CreateInterp call). */
2230     char *cmdName; /* Name of command to remove. */
2231     {
2232     Tcl_Command cmd;
2233    
2234     /*
2235     * Find the desired command and delete it.
2236     */
2237    
2238     cmd = Tcl_FindCommand(interp, cmdName, (Tcl_Namespace *) NULL,
2239     /*flags*/ 0);
2240     if (cmd == (Tcl_Command) NULL) {
2241     return -1;
2242     }
2243     return Tcl_DeleteCommandFromToken(interp, cmd);
2244     }
2245    
2246     /*
2247     *----------------------------------------------------------------------
2248     *
2249     * Tcl_DeleteCommandFromToken --
2250     *
2251     * Removes the given command from the given interpreter. This procedure
2252     * resembles Tcl_DeleteCommand, but takes a Tcl_Command token instead
2253     * of a command name for efficiency.
2254     *
2255     * Results:
2256     * 0 is returned if the command was deleted successfully.
2257     * -1 is returned if there didn't exist a command by that name.
2258     *
2259     * Side effects:
2260     * The command specified by "cmd" will no longer be recognized as a
2261     * valid command for "interp".
2262     *
2263     *----------------------------------------------------------------------
2264     */
2265    
2266     int
2267     Tcl_DeleteCommandFromToken(interp, cmd)
2268     Tcl_Interp *interp; /* Token for command interpreter returned by
2269     * a previous call to Tcl_CreateInterp. */
2270     Tcl_Command cmd; /* Token for command to delete. */
2271     {
2272     Interp *iPtr = (Interp *) interp;
2273     Command *cmdPtr = (Command *) cmd;
2274     ImportRef *refPtr, *nextRefPtr;
2275     Tcl_Command importCmd;
2276    
2277     /*
2278     * The code here is tricky. We can't delete the hash table entry
2279     * before invoking the deletion callback because there are cases
2280     * where the deletion callback needs to invoke the command (e.g.
2281     * object systems such as OTcl). However, this means that the
2282     * callback could try to delete or rename the command. The deleted
2283     * flag allows us to detect these cases and skip nested deletes.
2284     */
2285    
2286     if (cmdPtr->deleted) {
2287     /*
2288     * Another deletion is already in progress. Remove the hash
2289     * table entry now, but don't invoke a callback or free the
2290     * command structure.
2291     */
2292    
2293     Tcl_DeleteHashEntry(cmdPtr->hPtr);
2294     cmdPtr->hPtr = NULL;
2295     return 0;
2296     }
2297    
2298     /*
2299     * If the command being deleted has a compile procedure, increment the
2300     * interpreter's compileEpoch to invalidate its compiled code. This
2301     * makes sure that we don't later try to execute old code compiled with
2302     * command-specific (i.e., inline) bytecodes for the now-deleted
2303     * command. This field is checked in Tcl_EvalObj and ObjInterpProc, and
2304     * code whose compilation epoch doesn't match is recompiled.
2305     */
2306    
2307     if (cmdPtr->compileProc != NULL) {
2308     iPtr->compileEpoch++;
2309     }
2310    
2311     cmdPtr->deleted = 1;
2312     if (cmdPtr->deleteProc != NULL) {
2313     /*
2314     * Delete the command's client data. If this was an imported command
2315     * created when a command was imported into a namespace, this client
2316     * data will be a pointer to a ImportedCmdData structure describing
2317     * the "real" command that this imported command refers to.
2318     */
2319    
2320     /*
2321     * If you are getting a crash during the call to deleteProc and
2322     * cmdPtr->deleteProc is a pointer to the function free(), the
2323     * most likely cause is that your extension allocated memory
2324     * for the clientData argument to Tcl_CreateObjCommand() with
2325     * the ckalloc() macro and you are now trying to deallocate
2326     * this memory with free() instead of ckfree(). You should
2327     * pass a pointer to your own method that calls ckfree().
2328     */
2329    
2330     (*cmdPtr->deleteProc)(cmdPtr->deleteData);
2331     }
2332    
2333     /*
2334     * Bump the command epoch counter. This will invalidate all cached
2335     * references that point to this command.
2336     */
2337    
2338     cmdPtr->cmdEpoch++;
2339    
2340     /*
2341     * If this command was imported into other namespaces, then imported
2342     * commands were created that refer back to this command. Delete these
2343     * imported commands now.
2344     */
2345    
2346     for (refPtr = cmdPtr->importRefPtr; refPtr != NULL;
2347     refPtr = nextRefPtr) {
2348     nextRefPtr = refPtr->nextPtr;
2349     importCmd = (Tcl_Command) refPtr->importedCmdPtr;
2350     Tcl_DeleteCommandFromToken(interp, importCmd);
2351     }
2352    
2353     /*
2354     * Don't use hPtr to delete the hash entry here, because it's
2355     * possible that the deletion callback renamed the command.
2356     * Instead, use cmdPtr->hptr, and make sure that no-one else
2357     * has already deleted the hash entry.
2358     */
2359    
2360     if (cmdPtr->hPtr != NULL) {
2361     Tcl_DeleteHashEntry(cmdPtr->hPtr);
2362     }
2363    
2364     /*
2365     * Mark the Command structure as no longer valid. This allows
2366     * TclExecuteByteCode to recognize when a Command has logically been
2367     * deleted and a pointer to this Command structure cached in a CmdName
2368     * object is invalid. TclExecuteByteCode will look up the command again
2369     * in the interpreter's command hashtable.
2370     */
2371    
2372     cmdPtr->objProc = NULL;
2373    
2374     /*
2375     * Now free the Command structure, unless there is another reference to
2376     * it from a CmdName Tcl object in some ByteCode code sequence. In that
2377     * case, delay the cleanup until all references are either discarded
2378     * (when a ByteCode is freed) or replaced by a new reference (when a
2379     * cached CmdName Command reference is found to be invalid and
2380     * TclExecuteByteCode looks up the command in the command hashtable).
2381     */
2382    
2383     TclCleanupCommand(cmdPtr);
2384     return 0;
2385     }
2386    
2387     /*
2388     *----------------------------------------------------------------------
2389     *
2390     * TclCleanupCommand --
2391     *
2392     * This procedure frees up a Command structure unless it is still
2393     * referenced from an interpreter's command hashtable or from a CmdName
2394     * Tcl object representing the name of a command in a ByteCode
2395     * instruction sequence.
2396     *
2397     * Results:
2398     * None.
2399     *
2400     * Side effects:
2401     * Memory gets freed unless a reference to the Command structure still
2402     * exists. In that case the cleanup is delayed until the command is
2403     * deleted or when the last ByteCode referring to it is freed.
2404     *
2405     *----------------------------------------------------------------------
2406     */
2407    
2408     void
2409     TclCleanupCommand(cmdPtr)
2410     register Command *cmdPtr; /* Points to the Command structure to
2411     * be freed. */
2412     {
2413     cmdPtr->refCount--;
2414     if (cmdPtr->refCount <= 0) {
2415     ckfree((char *) cmdPtr);
2416     }
2417     }
2418    
2419     /*
2420     *----------------------------------------------------------------------
2421     *
2422     * Tcl_CreateMathFunc --
2423     *
2424     * Creates a new math function for expressions in a given
2425     * interpreter.
2426     *
2427     * Results:
2428     * None.
2429     *
2430     * Side effects:
2431     * The function defined by "name" is created or redefined. If the
2432     * function already exists then its definition is replaced; this
2433     * includes the builtin functions. Redefining a builtin function forces
2434     * all existing code to be invalidated since that code may be compiled
2435     * using an instruction specific to the replaced function. In addition,
2436     * redefioning a non-builtin function will force existing code to be
2437     * invalidated if the number of arguments has changed.
2438     *
2439     *----------------------------------------------------------------------
2440     */
2441    
2442     void
2443     Tcl_CreateMathFunc(interp, name, numArgs, argTypes, proc, clientData)
2444     Tcl_Interp *interp; /* Interpreter in which function is
2445     * to be available. */
2446     char *name; /* Name of function (e.g. "sin"). */
2447     int numArgs; /* Nnumber of arguments required by
2448     * function. */
2449     Tcl_ValueType *argTypes; /* Array of types acceptable for
2450     * each argument. */
2451     Tcl_MathProc *proc; /* Procedure that implements the
2452     * math function. */
2453     ClientData clientData; /* Additional value to pass to the
2454     * function. */
2455     {
2456     Interp *iPtr = (Interp *) interp;
2457     Tcl_HashEntry *hPtr;
2458     MathFunc *mathFuncPtr;
2459     int new, i;
2460    
2461     hPtr = Tcl_CreateHashEntry(&iPtr->mathFuncTable, name, &new);
2462     if (new) {
2463     Tcl_SetHashValue(hPtr, ckalloc(sizeof(MathFunc)));
2464     }
2465     mathFuncPtr = (MathFunc *) Tcl_GetHashValue(hPtr);
2466    
2467     if (!new) {
2468     if (mathFuncPtr->builtinFuncIndex >= 0) {
2469     /*
2470     * We are redefining a builtin math function. Invalidate the
2471     * interpreter's existing code by incrementing its
2472     * compileEpoch member. This field is checked in Tcl_EvalObj
2473     * and ObjInterpProc, and code whose compilation epoch doesn't
2474     * match is recompiled. Newly compiled code will no longer
2475     * treat the function as builtin.
2476     */
2477    
2478     iPtr->compileEpoch++;
2479     } else {
2480     /*
2481     * A non-builtin function is being redefined. We must invalidate
2482     * existing code if the number of arguments has changed. This
2483     * is because existing code was compiled assuming that number.
2484     */
2485    
2486     if (numArgs != mathFuncPtr->numArgs) {
2487     iPtr->compileEpoch++;
2488     }
2489     }
2490     }
2491    
2492     mathFuncPtr->builtinFuncIndex = -1; /* can't be a builtin function */
2493     if (numArgs > MAX_MATH_ARGS) {
2494     numArgs = MAX_MATH_ARGS;
2495     }
2496     mathFuncPtr->numArgs = numArgs;
2497     for (i = 0; i < numArgs; i++) {
2498     mathFuncPtr->argTypes[i] = argTypes[i];
2499     }
2500     mathFuncPtr->proc = proc;
2501     mathFuncPtr->clientData = clientData;
2502     }
2503    
2504     /*
2505     *----------------------------------------------------------------------
2506     *
2507     * Tcl_EvalObjEx --
2508     *
2509     * Execute Tcl commands stored in a Tcl object. These commands are
2510     * compiled into bytecodes if necessary, unless TCL_EVAL_DIRECT
2511     * is specified.
2512     *
2513     * Results:
2514     * The return value is one of the return codes defined in tcl.h
2515     * (such as TCL_OK), and the interpreter's result contains a value
2516     * to supplement the return code.
2517     *
2518     * Side effects:
2519     * The object is converted, if necessary, to a ByteCode object that
2520     * holds the bytecode instructions for the commands. Executing the
2521     * commands will almost certainly have side effects that depend
2522     * on those commands.
2523     *
2524     * Just as in Tcl_Eval, interp->termOffset is set to the offset of the
2525     * last character executed in the objPtr's string.
2526     *
2527     *----------------------------------------------------------------------
2528     */
2529    
2530     int
2531     Tcl_EvalObjEx(interp, objPtr, flags)
2532     Tcl_Interp *interp; /* Token for command interpreter
2533     * (returned by a previous call to
2534     * Tcl_CreateInterp). */
2535     register Tcl_Obj *objPtr; /* Pointer to object containing
2536     * commands to execute. */
2537     int flags; /* Collection of OR-ed bits that
2538     * control the evaluation of the
2539     * script. Supported values are
2540     * TCL_EVAL_GLOBAL and
2541     * TCL_EVAL_DIRECT. */
2542     {
2543     register Interp *iPtr = (Interp *) interp;
2544     int evalFlags; /* Interp->evalFlags value when the
2545     * procedure was called. */
2546     register ByteCode* codePtr; /* Tcl Internal type of bytecode. */
2547     int oldCount = iPtr->cmdCount; /* Used to tell whether any commands
2548     * at all were executed. */
2549     int numSrcBytes;
2550     int result;
2551     CallFrame *savedVarFramePtr; /* Saves old copy of iPtr->varFramePtr
2552     * in case TCL_EVAL_GLOBAL was set. */
2553     Namespace *namespacePtr;
2554    
2555     Tcl_IncrRefCount(objPtr);
2556    
2557     if ((iPtr->flags & USE_EVAL_DIRECT) || (flags & TCL_EVAL_DIRECT)) {
2558     /*
2559     * We're not supposed to use the compiler or byte-code interpreter.
2560     * Let Tcl_EvalEx evaluate the command directly (and probably
2561     * more slowly).
2562     *
2563     * Pure List Optimization (no string representation). In this
2564     * case, we can safely use Tcl_EvalObjv instead and get an
2565     * appreciable improvement in execution speed. This is because it
2566     * allows us to avoid a setFromAny step that would just pack
2567     * everything into a string and back out again.
2568     *
2569     * USE_EVAL_DIRECT is a special flag used for testing purpose only
2570     * (ensure we go into the TCL_EVAL_DIRECT path, avoiding opt)
2571     */
2572     if (!(iPtr->flags & USE_EVAL_DIRECT) &&
2573     (objPtr->typePtr == &tclListType) && /* is a list... */
2574     (objPtr->bytes == NULL) /* ...without a string rep */) {
2575     register List *listRepPtr =
2576     (List *) objPtr->internalRep.otherValuePtr;
2577     result = Tcl_EvalObjv(interp, listRepPtr->elemCount,
2578     listRepPtr->elements, flags);
2579     } else {
2580     register char *p;
2581     p = Tcl_GetStringFromObj(objPtr, &numSrcBytes);
2582     result = Tcl_EvalEx(interp, p, numSrcBytes, flags);
2583     }
2584     Tcl_DecrRefCount(objPtr);
2585     return result;
2586     }
2587    
2588     /*
2589     * Prevent the object from being deleted as a side effect of evaling it.
2590     */
2591    
2592     savedVarFramePtr = iPtr->varFramePtr;
2593     if (flags & TCL_EVAL_GLOBAL) {
2594     iPtr->varFramePtr = NULL;
2595     }
2596    
2597     /*
2598     * Reset both the interpreter's string and object results and clear out
2599     * any error information. This makes sure that we return an empty
2600     * result if there are no commands in the command string.
2601     */
2602    
2603     Tcl_ResetResult(interp);
2604    
2605     /*
2606     * Check depth of nested calls to Tcl_Eval: if this gets too large,
2607     * it's probably because of an infinite loop somewhere.
2608     */
2609    
2610     iPtr->numLevels++;
2611     if (iPtr->numLevels > iPtr->maxNestingDepth) {
2612     Tcl_AppendToObj(Tcl_GetObjResult(interp),
2613     "too many nested calls to Tcl_EvalObj (infinite loop?)", -1);
2614     result = TCL_ERROR;
2615     goto done;
2616     }
2617    
2618     /*
2619     * On the Mac, we will never reach the default recursion limit before
2620     * blowing the stack. So we need to do a check here.
2621     */
2622    
2623     if (TclpCheckStackSpace() == 0) {
2624     /*NOTREACHED*/
2625     Tcl_AppendToObj(Tcl_GetObjResult(interp),
2626     "too many nested calls to Tcl_EvalObj (infinite loop?)", -1);
2627     result = TCL_ERROR;
2628     goto done;
2629     }
2630    
2631     /*
2632     * If the interpreter has been deleted, return an error.
2633     */
2634    
2635     if (iPtr->flags & DELETED) {
2636     Tcl_ResetResult(interp);
2637     Tcl_AppendToObj(Tcl_GetObjResult(interp),
2638     "attempt to call eval in deleted interpreter", -1);
2639     Tcl_SetErrorCode(interp, "CORE", "IDELETE",
2640     "attempt to call eval in deleted interpreter",
2641     (char *) NULL);
2642     result = TCL_ERROR;
2643     goto done;
2644     }
2645    
2646     /*
2647     * Get the ByteCode from the object. If it exists, make sure it hasn't
2648     * been invalidated by, e.g., someone redefining a command with a
2649     * compile procedure (this might make the compiled code wrong). If
2650     * necessary, convert the object to be a ByteCode object and compile it.
2651     * Also, if the code was compiled in/for a different interpreter,
2652     * or for a different namespace, or for the same namespace but
2653     * with different name resolution rules, we recompile it.
2654     *
2655     * Precompiled objects, however, are immutable and therefore
2656     * they are not recompiled, even if the epoch has changed.
2657     *
2658     * To be pedantically correct, we should also check that the
2659     * originating procPtr is the same as the current context procPtr
2660     * (assuming one exists at all - none for global level). This
2661     * code is #def'ed out because [info body] was changed to never
2662     * return a bytecode type object, which should obviate us from
2663     * the extra checks here.
2664     */
2665    
2666     if (iPtr->varFramePtr != NULL) {
2667     namespacePtr = iPtr->varFramePtr->nsPtr;
2668     } else {
2669     namespacePtr = iPtr->globalNsPtr;
2670     }
2671    
2672     if (objPtr->typePtr == &tclByteCodeType) {
2673     codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr;
2674    
2675     if (((Interp *) *codePtr->interpHandle != iPtr)
2676     || (codePtr->compileEpoch != iPtr->compileEpoch)
2677     #ifdef CHECK_PROC_ORIGINATION /* [Bug: 3412 Pedantic] */
2678     || (codePtr->procPtr != NULL && !(iPtr->varFramePtr &&
2679     iPtr->varFramePtr->procPtr == codePtr->procPtr))
2680     #endif
2681     || (codePtr->nsPtr != namespacePtr)
2682     || (codePtr->nsEpoch != namespacePtr->resolverEpoch)) {
2683     if (codePtr->flags & TCL_BYTECODE_PRECOMPILED) {
2684     if ((Interp *) *codePtr->interpHandle != iPtr) {
2685     panic("Tcl_EvalObj: compiled script jumped interps");
2686     }
2687     codePtr->compileEpoch = iPtr->compileEpoch;
2688     } else {
2689     tclByteCodeType.freeIntRepProc(objPtr);
2690     }
2691     }
2692     }
2693     if (objPtr->typePtr != &tclByteCodeType) {
2694     iPtr->errorLine = 1;
2695     result = tclByteCodeType.setFromAnyProc(interp, objPtr);
2696     if (result != TCL_OK) {
2697     goto done;
2698     }
2699     } else {
2700     codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr;
2701     if (((Interp *) *codePtr->interpHandle != iPtr)
2702     || (codePtr->compileEpoch != iPtr->compileEpoch)) {
2703     (*tclByteCodeType.freeIntRepProc)(objPtr);
2704     iPtr->errorLine = 1;
2705     result = (*tclByteCodeType.setFromAnyProc)(interp, objPtr);
2706     if (result != TCL_OK) {
2707     iPtr->numLevels--;
2708     return result;
2709     }
2710     }
2711     }
2712     codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr;
2713    
2714     /*
2715     * Extract then reset the compilation flags in the interpreter.
2716     * Resetting the flags must be done after any compilation.
2717     */
2718    
2719     evalFlags = iPtr->evalFlags;
2720     iPtr->evalFlags = 0;
2721    
2722     /*
2723     * Execute the commands. If the code was compiled from an empty string,
2724     * don't bother executing the code.
2725     */
2726    
2727     numSrcBytes = codePtr->numSrcBytes;
2728     if ((numSrcBytes > 0) || (codePtr->flags & TCL_BYTECODE_PRECOMPILED)) {
2729     /*
2730     * Increment the code's ref count while it is being executed. If
2731     * afterwards no references to it remain, free the code.
2732     */
2733    
2734     codePtr->refCount++;
2735     result = TclExecuteByteCode(interp, codePtr);
2736     codePtr->refCount--;
2737     if (codePtr->refCount <= 0) {
2738     TclCleanupByteCode(codePtr);
2739     }
2740     } else {
2741     result = TCL_OK;
2742     }
2743    
2744     /*
2745     * If no commands at all were executed, check for asynchronous
2746     * handlers so that they at least get one change to execute.
2747     * This is needed to handle event loops written in Tcl with
2748     * empty bodies.
2749     */
2750    
2751     if ((oldCount == iPtr->cmdCount) && Tcl_AsyncReady()) {
2752     result = Tcl_AsyncInvoke(interp, result);
2753     }
2754    
2755     /*
2756     * Update the interpreter's evaluation level count. If we are again at
2757     * the top level, process any unusual return code returned by the
2758     * evaluated code.
2759     */
2760    
2761     if (iPtr->numLevels == 1) {
2762     if (result == TCL_RETURN) {
2763     result = TclUpdateReturnInfo(iPtr);
2764     }
2765     if ((result != TCL_OK) && (result != TCL_ERROR)
2766     && ((evalFlags & TCL_ALLOW_EXCEPTIONS) == 0)) {
2767     ProcessUnexpectedResult(interp, result);
2768     result = TCL_ERROR;
2769     }
2770     }
2771    
2772     /*
2773     * If an error occurred, record information about what was being
2774     * executed when the error occurred.
2775     */
2776    
2777     if ((result == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) {
2778     RecordTracebackInfo(interp, objPtr, numSrcBytes);
2779     }
2780    
2781     /*
2782     * Set the interpreter's termOffset member to the offset of the
2783     * character just after the last one executed. We approximate the offset
2784     * of the last character executed by using the number of characters
2785     * compiled.
2786     */
2787    
2788     iPtr->termOffset = numSrcBytes;
2789     iPtr->flags &= ~ERR_ALREADY_LOGGED;
2790    
2791     done:
2792     TclDecrRefCount(objPtr);
2793     iPtr->varFramePtr = savedVarFramePtr;
2794     iPtr->numLevels--;
2795     return result;
2796     }
2797    
2798     /*
2799     *----------------------------------------------------------------------
2800     *
2801     * ProcessUnexpectedResult --
2802     *
2803     * Procedure called by Tcl_EvalObj to set the interpreter's result
2804     * value to an appropriate error message when the code it evaluates
2805     * returns an unexpected result code (not TCL_OK and not TCL_ERROR) to
2806     * the topmost evaluation level.
2807     *
2808     * Results:
2809     * None.
2810     *
2811     * Side effects:
2812     * The interpreter result is set to an error message appropriate to
2813     * the result code.
2814     *
2815     *----------------------------------------------------------------------
2816     */
2817    
2818     static void
2819     ProcessUnexpectedResult(interp, returnCode)
2820     Tcl_Interp *interp; /* The interpreter in which the unexpected
2821     * result code was returned. */
2822     int returnCode; /* The unexpected result code. */
2823     {
2824     Tcl_ResetResult(interp);
2825     if (returnCode == TCL_BREAK) {
2826     Tcl_AppendToObj(Tcl_GetObjResult(interp),
2827     "invoked \"break\" outside of a loop", -1);
2828     } else if (returnCode == TCL_CONTINUE) {
2829     Tcl_AppendToObj(Tcl_GetObjResult(interp),
2830     "invoked \"continue\" outside of a loop", -1);
2831     } else {
2832     char buf[30 + TCL_INTEGER_SPACE];
2833    
2834     sprintf(buf, "command returned bad code: %d", returnCode);
2835     Tcl_SetResult(interp, buf, TCL_VOLATILE);
2836     }
2837     }
2838    
2839     /*
2840     *----------------------------------------------------------------------
2841     *
2842     * RecordTracebackInfo --
2843     *
2844     * Procedure called by Tcl_EvalObj to record information about what was
2845     * being executed when the error occurred.
2846     *
2847     * Results:
2848     * None.
2849     *
2850     * Side effects:
2851     * Appends information about the script being evaluated to the
2852     * interpreter's "errorInfo" variable.
2853     *
2854     *----------------------------------------------------------------------
2855     */
2856    
2857     static void
2858     RecordTracebackInfo(interp, objPtr, numSrcBytes)
2859     Tcl_Interp *interp; /* The interpreter in which the error
2860     * occurred. */
2861     Tcl_Obj *objPtr; /* Points to object containing script whose
2862     * evaluation resulted in an error. */
2863     int numSrcBytes; /* Number of bytes compiled in script. */
2864     {
2865     Interp *iPtr = (Interp *) interp;
2866     char buf[200];
2867     char *ellipsis, *bytes;
2868     int length;
2869    
2870     /*
2871     * Decide how much of the command to print in the error message
2872     * (up to a certain number of bytes).
2873     */
2874    
2875     bytes = Tcl_GetStringFromObj(objPtr, &length);
2876     length = TclMin(numSrcBytes, length);
2877    
2878     ellipsis = "";
2879     if (length > 150) {
2880     length = 150;
2881     ellipsis = " ...";
2882     }
2883    
2884     if (!(iPtr->flags & ERR_IN_PROGRESS)) {
2885     sprintf(buf, "\n while executing\n\"%.*s%s\"",
2886     length, bytes, ellipsis);
2887     } else {
2888     sprintf(buf, "\n invoked from within\n\"%.*s%s\"",
2889     length, bytes, ellipsis);
2890     }
2891     Tcl_AddObjErrorInfo(interp, buf, -1);
2892     }
2893    
2894     /*
2895     *---------------------------------------------------------------------------
2896     *
2897     * Tcl_ExprLong, Tcl_ExprDouble, Tcl_ExprBoolean --
2898     *
2899     * Procedures to evaluate an expression and return its value in a
2900     * particular form.
2901     *
2902     * Results:
2903     * Each of the procedures below returns a standard Tcl result. If an
2904     * error occurs then an error message is left in the interp's result.
2905     * Otherwise the value of the expression, in the appropriate form,
2906     * is stored at *ptr. If the expression had a result that was
2907     * incompatible with the desired form then an error is returned.
2908     *
2909     * Side effects:
2910     * None.
2911     *
2912     *---------------------------------------------------------------------------
2913     */
2914    
2915     int
2916     Tcl_ExprLong(interp, string, ptr)
2917     Tcl_Interp *interp; /* Context in which to evaluate the
2918     * expression. */
2919     char *string; /* Expression to evaluate. */
2920     long *ptr; /* Where to store result. */
2921     {
2922     register Tcl_Obj *exprPtr;
2923     Tcl_Obj *resultPtr;
2924     int length = strlen(string);
2925     int result = TCL_OK;
2926    
2927     if (length > 0) {
2928     exprPtr = Tcl_NewStringObj(string, length);
2929     Tcl_IncrRefCount(exprPtr);
2930     result = Tcl_ExprObj(interp, exprPtr, &resultPtr);
2931     if (result == TCL_OK) {
2932     /*
2933     * Store an integer based on the expression result.
2934     */
2935    
2936     if (resultPtr->typePtr == &tclIntType) {
2937     *ptr = resultPtr->internalRep.longValue;
2938     } else if (resultPtr->typePtr == &tclDoubleType) {
2939     *ptr = (long) resultPtr->internalRep.doubleValue;
2940     } else {
2941     Tcl_SetResult(interp,
2942     "expression didn't have numeric value", TCL_STATIC);
2943     result = TCL_ERROR;
2944     }
2945     Tcl_DecrRefCount(resultPtr); /* discard the result object */
2946     } else {
2947     /*
2948     * Move the interpreter's object result to the string result,
2949     * then reset the object result.
2950     */
2951    
2952     Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)),
2953     TCL_VOLATILE);
2954     }
2955     Tcl_DecrRefCount(exprPtr); /* discard the expression object */
2956     } else {
2957     /*
2958     * An empty string. Just set the result integer to 0.
2959     */
2960    
2961     *ptr = 0;
2962     }
2963     return result;
2964     }
2965    
2966     int
2967     Tcl_ExprDouble(interp, string, ptr)
2968     Tcl_Interp *interp; /* Context in which to evaluate the
2969     * expression. */
2970     char *string; /* Expression to evaluate. */
2971     double *ptr; /* Where to store result. */
2972     {
2973     register Tcl_Obj *exprPtr;
2974     Tcl_Obj *resultPtr;
2975     int length = strlen(string);
2976     int result = TCL_OK;
2977    
2978     if (length > 0) {
2979     exprPtr = Tcl_NewStringObj(string, length);
2980     Tcl_IncrRefCount(exprPtr);
2981     result = Tcl_ExprObj(interp, exprPtr, &resultPtr);
2982     if (result == TCL_OK) {
2983     /*
2984     * Store a double based on the expression result.
2985     */
2986    
2987     if (resultPtr->typePtr == &tclIntType) {
2988     *ptr = (double) resultPtr->internalRep.longValue;
2989     } else if (resultPtr->typePtr == &tclDoubleType) {
2990     *ptr = resultPtr->internalRep.doubleValue;
2991     } else {
2992     Tcl_SetResult(interp,
2993     "expression didn't have numeric value", TCL_STATIC);
2994     result = TCL_ERROR;
2995     }
2996     Tcl_DecrRefCount(resultPtr); /* discard the result object */
2997     } else {
2998     /*
2999     * Move the interpreter's object result to the string result,
3000     * then reset the object result.
3001     */
3002    
3003     Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)),
3004     TCL_VOLATILE);
3005     }
3006     Tcl_DecrRefCount(exprPtr); /* discard the expression object */
3007     } else {
3008     /*
3009     * An empty string. Just set the result double to 0.0.
3010     */
3011    
3012     *ptr = 0.0;
3013     }
3014     return result;
3015     }
3016    
3017     int
3018     Tcl_ExprBoolean(interp, string, ptr)
3019     Tcl_Interp *interp; /* Context in which to evaluate the
3020     * expression. */
3021     char *string; /* Expression to evaluate. */
3022     int *ptr; /* Where to store 0/1 result. */
3023     {
3024     register Tcl_Obj *exprPtr;
3025     Tcl_Obj *resultPtr;
3026     int length = strlen(string);
3027     int result = TCL_OK;
3028    
3029     if (length > 0) {
3030     exprPtr = Tcl_NewStringObj(string, length);
3031     Tcl_IncrRefCount(exprPtr);
3032     result = Tcl_ExprObj(interp, exprPtr, &resultPtr);
3033     if (result == TCL_OK) {
3034     /*
3035     * Store a boolean based on the expression result.
3036     */
3037    
3038     if (resultPtr->typePtr == &tclIntType) {
3039     *ptr = (resultPtr->internalRep.longValue != 0);
3040     } else if (resultPtr->typePtr == &tclDoubleType) {
3041     *ptr = (resultPtr->internalRep.doubleValue != 0.0);
3042     } else {
3043     result = Tcl_GetBooleanFromObj(interp, resultPtr, ptr);
3044     }
3045     Tcl_DecrRefCount(resultPtr); /* discard the result object */
3046     }
3047     if (result != TCL_OK) {
3048     /*
3049     * Move the interpreter's object result to the string result,
3050     * then reset the object result.
3051     */
3052    
3053     Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)),
3054     TCL_VOLATILE);
3055     }
3056     Tcl_DecrRefCount(exprPtr); /* discard the expression object */
3057     } else {
3058     /*
3059     * An empty string. Just set the result boolean to 0 (false).
3060     */
3061    
3062     *ptr = 0;
3063     }
3064     return result;
3065     }
3066    
3067     /*
3068     *--------------------------------------------------------------
3069     *
3070     * Tcl_ExprLongObj, Tcl_ExprDoubleObj, Tcl_ExprBooleanObj --
3071     *
3072     * Procedures to evaluate an expression in an object and return its
3073     * value in a particular form.
3074     *
3075     * Results:
3076     * Each of the procedures below returns a standard Tcl result
3077     * object. If an error occurs then an error message is left in the
3078     * interpreter's result. Otherwise the value of the expression, in the
3079     * appropriate form, is stored at *ptr. If the expression had a result
3080     * that was incompatible with the desired form then an error is
3081     * returned.
3082     *
3083     * Side effects:
3084     * None.
3085     *
3086     *--------------------------------------------------------------
3087     */
3088    
3089     int
3090     Tcl_ExprLongObj(interp, objPtr, ptr)
3091     Tcl_Interp *interp; /* Context in which to evaluate the
3092     * expression. */
3093     register Tcl_Obj *objPtr; /* Expression to evaluate. */
3094     long *ptr; /* Where to store long result. */
3095     {
3096     Tcl_Obj *resultPtr;
3097     int result;
3098    
3099     result = Tcl_ExprObj(interp, objPtr, &resultPtr);
3100     if (result == TCL_OK) {
3101     if (resultPtr->typePtr == &tclIntType) {
3102     *ptr = resultPtr->internalRep.longValue;
3103     } else if (resultPtr->typePtr == &tclDoubleType) {
3104     *ptr = (long) resultPtr->internalRep.doubleValue;
3105     } else {
3106     result = Tcl_GetLongFromObj(interp, resultPtr, ptr);
3107     if (result != TCL_OK) {
3108     return result;
3109     }
3110     }
3111     Tcl_DecrRefCount(resultPtr); /* discard the result object */
3112     }
3113     return result;
3114     }
3115    
3116     int
3117     Tcl_ExprDoubleObj(interp, objPtr, ptr)
3118     Tcl_Interp *interp; /* Context in which to evaluate the
3119     * expression. */
3120     register Tcl_Obj *objPtr; /* Expression to evaluate. */
3121     double *ptr; /* Where to store double result. */
3122     {
3123     Tcl_Obj *resultPtr;
3124     int result;
3125    
3126     result = Tcl_ExprObj(interp, objPtr, &resultPtr);
3127     if (result == TCL_OK) {
3128     if (resultPtr->typePtr == &tclIntType) {
3129     *ptr = (double) resultPtr->internalRep.longValue;
3130     } else if (resultPtr->typePtr == &tclDoubleType) {
3131     *ptr = resultPtr->internalRep.doubleValue;
3132     } else {
3133     result = Tcl_GetDoubleFromObj(interp, resultPtr, ptr);
3134     if (result != TCL_OK) {
3135     return result;
3136     }
3137     }
3138     Tcl_DecrRefCount(resultPtr); /* discard the result object */
3139     }
3140     return result;
3141     }
3142    
3143     int
3144     Tcl_ExprBooleanObj(interp, objPtr, ptr)
3145     Tcl_Interp *interp; /* Context in which to evaluate the
3146     * expression. */
3147     register Tcl_Obj *objPtr; /* Expression to evaluate. */
3148     int *ptr; /* Where to store 0/1 result. */
3149     {
3150     Tcl_Obj *resultPtr;
3151     int result;
3152    
3153     result = Tcl_ExprObj(interp, objPtr, &resultPtr);
3154     if (result == TCL_OK) {
3155     if (resultPtr->typePtr == &tclIntType) {
3156     *ptr = (resultPtr->internalRep.longValue != 0);
3157     } else if (resultPtr->typePtr == &tclDoubleType) {
3158     *ptr = (resultPtr->internalRep.doubleValue != 0.0);
3159     } else {
3160     result = Tcl_GetBooleanFromObj(interp, resultPtr, ptr);
3161     }
3162     Tcl_DecrRefCount(resultPtr); /* discard the result object */
3163     }
3164     return result;
3165     }
3166    
3167     /*
3168     *----------------------------------------------------------------------
3169     *
3170     * TclInvoke --
3171     *
3172     * Invokes a Tcl command, given an argv/argc, from either the
3173     * exposed or the hidden sets of commands in the given interpreter.
3174     * NOTE: The command is invoked in the current stack frame of
3175     * the interpreter, thus it can modify local variables.
3176     *
3177     * Results:
3178     * A standard Tcl result.
3179     *
3180     * Side effects:
3181     * Whatever the command does.
3182     *
3183     *----------------------------------------------------------------------
3184     */
3185    
3186     int
3187     TclInvoke(interp, argc, argv, flags)
3188     Tcl_Interp *interp; /* Where to invoke the command. */
3189     int argc; /* Count of args. */
3190     register char **argv; /* The arg strings; argv[0] is the name of
3191     * the command to invoke. */
3192     int flags; /* Combination of flags controlling the
3193     * call: TCL_INVOKE_HIDDEN and
3194     * TCL_INVOKE_NO_UNKNOWN. */
3195     {
3196     register Tcl_Obj *objPtr;
3197     register int i;
3198     int length, result;
3199    
3200     /*
3201     * This procedure generates an objv array for object arguments that hold
3202     * the argv strings. It starts out with stack-allocated space but uses
3203     * dynamically-allocated storage if needed.
3204     */
3205    
3206     #define NUM_ARGS 20
3207     Tcl_Obj *(objStorage[NUM_ARGS]);
3208     register Tcl_Obj **objv = objStorage;
3209    
3210     /*
3211     * Create the object argument array "objv". Make sure objv is large
3212     * enough to hold the objc arguments plus 1 extra for the zero
3213     * end-of-objv word.
3214     */
3215    
3216     if ((argc + 1) > NUM_ARGS) {
3217     objv = (Tcl_Obj **)
3218     ckalloc((unsigned)(argc + 1) * sizeof(Tcl_Obj *));
3219     }
3220    
3221     for (i = 0; i < argc; i++) {
3222     length = strlen(argv[i]);
3223     objv[i] = Tcl_NewStringObj(argv[i], length);
3224     Tcl_IncrRefCount(objv[i]);
3225     }
3226     objv[argc] = 0;
3227    
3228     /*
3229     * Use TclObjInterpProc to actually invoke the command.
3230     */
3231    
3232     result = TclObjInvoke(interp, argc, objv, flags);
3233    
3234     /*
3235     * Move the interpreter's object result to the string result,
3236     * then reset the object result.
3237     */
3238    
3239     Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)),
3240     TCL_VOLATILE);
3241    
3242     /*
3243     * Decrement the ref counts on the objv elements since we are done
3244     * with them.
3245     */
3246    
3247     for (i = 0; i < argc; i++) {
3248     objPtr = objv[i];
3249     Tcl_DecrRefCount(objPtr);
3250     }
3251    
3252     /*
3253     * Free the objv array if malloc'ed storage was used.
3254     */
3255    
3256     if (objv != objStorage) {
3257     ckfree((char *) objv);
3258     }
3259     return result;
3260     #undef NUM_ARGS
3261     }
3262    
3263     /*
3264     *----------------------------------------------------------------------
3265     *
3266     * TclGlobalInvoke --
3267     *
3268     * Invokes a Tcl command, given an argv/argc, from either the
3269     * exposed or hidden sets of commands in the given interpreter.
3270     * NOTE: The command is invoked in the global stack frame of
3271     * the interpreter, thus it cannot see any current state on
3272     * the stack for that interpreter.
3273     *
3274     * Results:
3275     * A standard Tcl result.
3276     *
3277     * Side effects:
3278     * Whatever the command does.
3279     *
3280     *----------------------------------------------------------------------
3281     */
3282    
3283     int
3284     TclGlobalInvoke(interp, argc, argv, flags)
3285     Tcl_Interp *interp; /* Where to invoke the command. */
3286     int argc; /* Count of args. */
3287     register char **argv; /* The arg strings; argv[0] is the name of
3288     * the command to invoke. */
3289     int flags; /* Combination of flags controlling the
3290     * call: TCL_INVOKE_HIDDEN and
3291     * TCL_INVOKE_NO_UNKNOWN. */
3292     {
3293     register Interp *iPtr = (Interp *) interp;
3294     int result;
3295     CallFrame *savedVarFramePtr;
3296    
3297     savedVarFramePtr = iPtr->varFramePtr;
3298     iPtr->varFramePtr = NULL;
3299     result = TclInvoke(interp, argc, argv, flags);
3300     iPtr->varFramePtr = savedVarFramePtr;
3301     return result;
3302     }
3303    
3304     /*
3305     *----------------------------------------------------------------------
3306     *
3307     * TclObjInvokeGlobal --
3308     *
3309     * Object version: Invokes a Tcl command, given an objv/objc, from
3310     * either the exposed or hidden set of commands in the given
3311     * interpreter.
3312     * NOTE: The command is invoked in the global stack frame of the
3313     * interpreter, thus it cannot see any current state on the
3314     * stack of that interpreter.
3315     *
3316     * Results:
3317     * A standard Tcl result.
3318     *
3319     * Side effects:
3320     * Whatever the command does.
3321     *
3322     *----------------------------------------------------------------------
3323     */
3324    
3325     int
3326     TclObjInvokeGlobal(interp, objc, objv, flags)
3327     Tcl_Interp *interp; /* Interpreter in which command is to be
3328     * invoked. */
3329     int objc; /* Count of arguments. */
3330     Tcl_Obj *CONST objv[]; /* Argument objects; objv[0] points to the
3331     * name of the command to invoke. */
3332     int flags; /* Combination of flags controlling the
3333     * call: TCL_INVOKE_HIDDEN,
3334     * TCL_INVOKE_NO_UNKNOWN, or
3335     * TCL_INVOKE_NO_TRACEBACK. */
3336     {
3337     register Interp *iPtr = (Interp *) interp;
3338     int result;
3339     CallFrame *savedVarFramePtr;
3340    
3341     savedVarFramePtr = iPtr->varFramePtr;
3342     iPtr->varFramePtr = NULL;
3343     result = TclObjInvoke(interp, objc, objv, flags);
3344     iPtr->varFramePtr = savedVarFramePtr;
3345     return result;
3346     }
3347    
3348     /*
3349     *----------------------------------------------------------------------
3350     *
3351     * TclObjInvoke --
3352     *
3353     * Invokes a Tcl command, given an objv/objc, from either the
3354     * exposed or the hidden sets of commands in the given interpreter.
3355     *
3356     * Results:
3357     * A standard Tcl object result.
3358     *
3359     * Side effects:
3360     * Whatever the command does.
3361     *
3362     *----------------------------------------------------------------------
3363     */
3364    
3365     int
3366     TclObjInvoke(interp, objc, objv, flags)
3367     Tcl_Interp *interp; /* Interpreter in which command is to be
3368     * invoked. */
3369     int objc; /* Count of arguments. */
3370     Tcl_Obj *CONST objv[]; /* Argument objects; objv[0] points to the
3371     * name of the command to invoke. */
3372     int flags; /* Combination of flags controlling the
3373     * call: TCL_INVOKE_HIDDEN,
3374     * TCL_INVOKE_NO_UNKNOWN, or
3375     * TCL_INVOKE_NO_TRACEBACK. */
3376     {
3377     register Interp *iPtr = (Interp *) interp;
3378     Tcl_HashTable *hTblPtr; /* Table of hidden commands. */
3379     char *cmdName; /* Name of the command from objv[0]. */
3380     register Tcl_HashEntry *hPtr;
3381     Tcl_Command cmd;
3382     Command *cmdPtr;
3383     int localObjc; /* Used to invoke "unknown" if the */
3384     Tcl_Obj **localObjv = NULL; /* command is not found. */
3385     register int i;
3386     int length, result;
3387     char *bytes;
3388    
3389     if (interp == (Tcl_Interp *) NULL) {
3390     return TCL_ERROR;
3391     }
3392    
3393     if ((objc < 1) || (objv == (Tcl_Obj **) NULL)) {
3394     Tcl_AppendToObj(Tcl_GetObjResult(interp),
3395     "illegal argument vector", -1);
3396     return TCL_ERROR;
3397     }
3398    
3399     cmdName = Tcl_GetString(objv[0]);
3400     if (flags & TCL_INVOKE_HIDDEN) {
3401     /*
3402     * We never invoke "unknown" for hidden commands.
3403     */
3404    
3405     hPtr = NULL;
3406     hTblPtr = ((Interp *) interp)->hiddenCmdTablePtr;
3407     if (hTblPtr != NULL) {
3408     hPtr = Tcl_FindHashEntry(hTblPtr, cmdName);
3409     }
3410     if (hPtr == NULL) {
3411     Tcl_ResetResult(interp);
3412     Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
3413     "invalid hidden command name \"", cmdName, "\"",
3414     (char *) NULL);
3415     return TCL_ERROR;
3416     }
3417     cmdPtr = (Command *) Tcl_GetHashValue(hPtr);
3418     } else {
3419     cmdPtr = NULL;
3420     cmd = Tcl_FindCommand(interp, cmdName,
3421     (Tcl_Namespace *) NULL, /*flags*/ TCL_GLOBAL_ONLY);
3422     if (cmd != (Tcl_Command) NULL) {
3423     cmdPtr = (Command *) cmd;
3424     }
3425     if (cmdPtr == NULL) {
3426     if (!(flags & TCL_INVOKE_NO_UNKNOWN)) {
3427     cmd = Tcl_FindCommand(interp, "unknown",
3428     (Tcl_Namespace *) NULL, /*flags*/ TCL_GLOBAL_ONLY);
3429     if (cmd != (Tcl_Command) NULL) {
3430     cmdPtr = (Command *) cmd;
3431     }
3432     if (cmdPtr != NULL) {
3433     localObjc = (objc + 1);
3434     localObjv = (Tcl_Obj **)
3435     ckalloc((unsigned) (sizeof(Tcl_Obj *) * localObjc));
3436     localObjv[0] = Tcl_NewStringObj("unknown", -1);
3437     Tcl_IncrRefCount(localObjv[0]);
3438     for (i = 0; i < objc; i++) {
3439     localObjv[i+1] = objv[i];
3440     }
3441     objc = localObjc;
3442     objv = localObjv;
3443     }
3444     }
3445    
3446     /*
3447     * Check again if we found the command. If not, "unknown" is
3448     * not present and we cannot help, or the caller said not to
3449     * call "unknown" (they specified TCL_INVOKE_NO_UNKNOWN).
3450     */
3451    
3452     if (cmdPtr == NULL) {
3453     Tcl_ResetResult(interp);
3454     Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
3455     "invalid command name \"", cmdName, "\"",
3456     (char *) NULL);
3457     return TCL_ERROR;
3458     }
3459     }
3460     }
3461    
3462     /*
3463     * Invoke the command procedure. First reset the interpreter's string
3464     * and object results to their default empty values since they could
3465     * have gotten changed by earlier invocations.
3466     */
3467    
3468     Tcl_ResetResult(interp);
3469     iPtr->cmdCount++;
3470     result = (*cmdPtr->objProc)(cmdPtr->objClientData, interp, objc, objv);
3471    
3472     /*
3473     * If an error occurred, record information about what was being
3474     * executed when the error occurred.
3475     */
3476    
3477     if ((result == TCL_ERROR)
3478     && ((flags & TCL_INVOKE_NO_TRACEBACK) == 0)
3479     && ((iPtr->flags & ERR_ALREADY_LOGGED) == 0)) {
3480     Tcl_DString ds;
3481    
3482     Tcl_DStringInit(&ds);
3483     if (!(iPtr->flags & ERR_IN_PROGRESS)) {
3484     Tcl_DStringAppend(&ds, "\n while invoking\n\"", -1);
3485     } else {
3486     Tcl_DStringAppend(&ds, "\n invoked from within\n\"", -1);
3487     }
3488     for (i = 0; i < objc; i++) {
3489     bytes = Tcl_GetStringFromObj(objv[i], &length);
3490     Tcl_DStringAppend(&ds, bytes, length);
3491     if (i < (objc - 1)) {
3492     Tcl_DStringAppend(&ds, " ", -1);
3493     } else if (Tcl_DStringLength(&ds) > 100) {
3494     Tcl_DStringSetLength(&ds, 100);
3495     Tcl_DStringAppend(&ds, "...", -1);
3496     break;
3497     }
3498     }
3499    
3500     Tcl_DStringAppend(&ds, "\"", -1);
3501     Tcl_AddObjErrorInfo(interp, Tcl_DStringValue(&ds), -1);
3502     Tcl_DStringFree(&ds);
3503     iPtr->flags &= ~ERR_ALREADY_LOGGED;
3504     }
3505    
3506     /*
3507     * Free any locally allocated storage used to call "unknown".
3508     */
3509    
3510     if (localObjv != (Tcl_Obj **) NULL) {
3511     Tcl_DecrRefCount(localObjv[0]);
3512     ckfree((char *) localObjv);
3513     }
3514     return result;
3515     }
3516    
3517     /*
3518     *---------------------------------------------------------------------------
3519     *
3520     * Tcl_ExprString --
3521     *
3522     * Evaluate an expression in a string and return its value in string
3523     * form.
3524     *
3525     * Results:
3526     * A standard Tcl result. If the result is TCL_OK, then the interp's
3527     * result is set to the string value of the expression. If the result
3528     * is TCL_ERROR, then the interp's result contains an error message.
3529     *
3530     * Side effects:
3531     * A Tcl object is allocated to hold a copy of the expression string.
3532     * This expression object is passed to Tcl_ExprObj and then
3533     * deallocated.
3534     *
3535     *---------------------------------------------------------------------------
3536     */
3537    
3538     int
3539     Tcl_ExprString(interp, string)
3540     Tcl_Interp *interp; /* Context in which to evaluate the
3541     * expression. */
3542     char *string; /* Expression to evaluate. */
3543     {
3544     register Tcl_Obj *exprPtr;
3545     Tcl_Obj *resultPtr;
3546     int length = strlen(string);
3547     char buf[TCL_DOUBLE_SPACE];
3548     int result = TCL_OK;
3549    
3550     if (length > 0) {
3551     TclNewObj(exprPtr);
3552     TclInitStringRep(exprPtr, string, length);
3553     Tcl_IncrRefCount(exprPtr);
3554    
3555     result = Tcl_ExprObj(interp, exprPtr, &resultPtr);
3556     if (result == TCL_OK) {
3557     /*
3558     * Set the interpreter's string result from the result object.
3559     */
3560    
3561     if (resultPtr->typePtr == &tclIntType) {
3562     sprintf(buf, "%ld", resultPtr->internalRep.longValue);
3563     Tcl_SetResult(interp, buf, TCL_VOLATILE);
3564     } else if (resultPtr->typePtr == &tclDoubleType) {
3565     Tcl_PrintDouble((Tcl_Interp *) NULL,
3566     resultPtr->internalRep.doubleValue, buf);
3567     Tcl_SetResult(interp, buf, TCL_VOLATILE);
3568     } else {
3569     /*
3570     * Set interpreter's string result from the result object.
3571     */
3572    
3573     Tcl_SetResult(interp, TclGetString(resultPtr),
3574     TCL_VOLATILE);
3575     }
3576     Tcl_DecrRefCount(resultPtr); /* discard the result object */
3577     } else {
3578     /*
3579     * Move the interpreter's object result to the string result,
3580     * then reset the object result.
3581     */
3582    
3583     Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)),
3584     TCL_VOLATILE);
3585     }
3586     Tcl_DecrRefCount(exprPtr); /* discard the expression object */
3587     } else {
3588     /*
3589     * An empty string. Just set the interpreter's result to 0.
3590     */
3591    
3592     Tcl_SetResult(interp, "0", TCL_VOLATILE);
3593     }
3594     return result;
3595     }
3596    
3597     /*
3598     *--------------------------------------------------------------
3599     *
3600     * Tcl_ExprObj --
3601     *
3602     * Evaluate an expression in a Tcl_Obj.
3603     *
3604     * Results:
3605     * A standard Tcl object result. If the result is other than TCL_OK,
3606     * then the interpreter's result contains an error message. If the
3607     * result is TCL_OK, then a pointer to the expression's result value
3608     * object is stored in resultPtrPtr. In that case, the object's ref
3609     * count is incremented to reflect the reference returned to the
3610     * caller; the caller is then responsible for the resulting object
3611     * and must, for example, decrement the ref count when it is finished
3612     * with the object.
3613     *
3614     * Side effects:
3615     * Any side effects caused by subcommands in the expression, if any.
3616     * The interpreter result is not modified unless there is an error.
3617     *
3618     *--------------------------------------------------------------
3619     */
3620    
3621     int
3622     Tcl_ExprObj(interp, objPtr, resultPtrPtr)
3623     Tcl_Interp *interp; /* Context in which to evaluate the
3624     * expression. */
3625     register Tcl_Obj *objPtr; /* Points to Tcl object containing
3626     * expression to evaluate. */
3627     Tcl_Obj **resultPtrPtr; /* Where the Tcl_Obj* that is the expression
3628     * result is stored if no errors occur. */
3629     {
3630     Interp *iPtr = (Interp *) interp;
3631     CompileEnv compEnv; /* Compilation environment structure
3632     * allocated in frame. */
3633     LiteralTable *localTablePtr = &(compEnv.localLitTable);
3634     register ByteCode *codePtr = NULL;
3635     /* Tcl Internal type of bytecode.
3636     * Initialized to avoid compiler warning. */
3637     AuxData *auxDataPtr;
3638     LiteralEntry *entryPtr;
3639     Tcl_Obj *saveObjPtr;
3640     char *string;
3641     int length, i, result;
3642    
3643     /*
3644     * First handle some common expressions specially.
3645     */
3646    
3647     string = Tcl_GetStringFromObj(objPtr, &length);
3648     if (length == 1) {
3649     if (*string == '0') {
3650     *resultPtrPtr = Tcl_NewLongObj(0);
3651     Tcl_IncrRefCount(*resultPtrPtr);
3652     return TCL_OK;
3653     } else if (*string == '1') {
3654     *resultPtrPtr = Tcl_NewLongObj(1);
3655     Tcl_IncrRefCount(*resultPtrPtr);
3656     return TCL_OK;
3657     }
3658     } else if ((length == 2) && (*string == '!')) {
3659     if (*(string+1) == '0') {
3660     *resultPtrPtr = Tcl_NewLongObj(1);
3661     Tcl_IncrRefCount(*resultPtrPtr);
3662     return TCL_OK;
3663     } else if (*(string+1) == '1') {
3664     *resultPtrPtr = Tcl_NewLongObj(0);
3665     Tcl_IncrRefCount(*resultPtrPtr);
3666     return TCL_OK;
3667     }
3668     }
3669    
3670     /*
3671     * Get the ByteCode from the object. If it exists, make sure it hasn't
3672     * been invalidated by, e.g., someone redefining a command with a
3673     * compile procedure (this might make the compiled code wrong). If
3674     * necessary, convert the object to be a ByteCode object and compile it.
3675     * Also, if the code was compiled in/for a different interpreter, we
3676     * recompile it.
3677     *
3678     * Precompiled expressions, however, are immutable and therefore
3679     * they are not recompiled, even if the epoch has changed.
3680     *
3681     */
3682    
3683     if (objPtr->typePtr == &tclByteCodeType) {
3684     codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr;
3685     if (((Interp *) *codePtr->interpHandle != iPtr)
3686     || (codePtr->compileEpoch != iPtr->compileEpoch)) {
3687     if (codePtr->flags & TCL_BYTECODE_PRECOMPILED) {
3688     if ((Interp *) *codePtr->interpHandle != iPtr) {
3689     panic("Tcl_ExprObj: compiled expression jumped interps");
3690     }
3691     codePtr->compileEpoch = iPtr->compileEpoch;
3692     } else {
3693     (*tclByteCodeType.freeIntRepProc)(objPtr);
3694     objPtr->typePtr = (Tcl_ObjType *) NULL;
3695     }
3696     }
3697     }
3698     if (objPtr->typePtr != &tclByteCodeType) {
3699     TclInitCompileEnv(interp, &compEnv, string, length);
3700     result = TclCompileExpr(interp, string, length, &compEnv);
3701    
3702     /*
3703     * Free the compilation environment's literal table bucket array if
3704     * it was dynamically allocated.
3705     */
3706    
3707     if (localTablePtr->buckets != localTablePtr->staticBuckets) {
3708     ckfree((char *) localTablePtr->buckets);
3709     }
3710    
3711     if (result != TCL_OK) {
3712     /*
3713     * Compilation errors. Free storage allocated for compilation.
3714     */
3715    
3716     #ifdef TCL_COMPILE_DEBUG
3717     TclVerifyLocalLiteralTable(&compEnv);
3718     #endif /*TCL_COMPILE_DEBUG*/
3719     entryPtr = compEnv.literalArrayPtr;
3720     for (i = 0; i < compEnv.literalArrayNext; i++) {
3721     TclReleaseLiteral(interp, entryPtr->objPtr);
3722     entryPtr++;
3723     }
3724     #ifdef TCL_COMPILE_DEBUG
3725     TclVerifyGlobalLiteralTable(iPtr);
3726     #endif /*TCL_COMPILE_DEBUG*/
3727    
3728     auxDataPtr = compEnv.auxDataArrayPtr;
3729     for (i = 0; i < compEnv.auxDataArrayNext; i++) {
3730     if (auxDataPtr->type->freeProc != NULL) {
3731     auxDataPtr->type->freeProc(auxDataPtr->clientData);
3732     }
3733     auxDataPtr++;
3734     }
3735     TclFreeCompileEnv(&compEnv);
3736     return result;
3737     }
3738    
3739     /*
3740     * Successful compilation. If the expression yielded no
3741     * instructions, push an zero object as the expression's result.
3742     */
3743    
3744     if (compEnv.codeNext == compEnv.codeStart) {
3745     TclEmitPush(TclRegisterLiteral(&compEnv, "0", 1, /*onHeap*/ 0),
3746     &compEnv);
3747     }
3748    
3749     /*
3750     * Add a "done" instruction as the last instruction and change the
3751     * object into a ByteCode object. Ownership of the literal objects
3752     * and aux data items is given to the ByteCode object.
3753     */
3754    
3755     compEnv.numSrcBytes = iPtr->termOffset;
3756     TclEmitOpcode(INST_DONE, &compEnv);
3757     TclInitByteCodeObj(objPtr, &compEnv);
3758     TclFreeCompileEnv(&compEnv);
3759     codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr;
3760     #ifdef TCL_COMPILE_DEBUG
3761     if (tclTraceCompile == 2) {
3762     TclPrintByteCodeObj(interp, objPtr);
3763     }
3764     #endif /* TCL_COMPILE_DEBUG */
3765     }
3766    
3767     /*
3768     * Execute the expression after first saving the interpreter's result.
3769     */
3770    
3771     saveObjPtr = Tcl_GetObjResult(interp);
3772     Tcl_IncrRefCount(saveObjPtr);
3773     Tcl_ResetResult(interp);
3774    
3775     /*
3776     * Increment the code's ref count while it is being executed. If
3777     * afterwards no references to it remain, free the code.
3778     */
3779    
3780     codePtr->refCount++;
3781     result = TclExecuteByteCode(interp, codePtr);
3782     codePtr->refCount--;
3783     if (codePtr->refCount <= 0) {
3784     TclCleanupByteCode(codePtr);
3785     objPtr->typePtr = NULL;
3786     objPtr->internalRep.otherValuePtr = NULL;
3787     }
3788    
3789     /*
3790     * If the expression evaluated successfully, store a pointer to its
3791     * value object in resultPtrPtr then restore the old interpreter result.
3792     * We increment the object's ref count to reflect the reference that we
3793     * are returning to the caller. We also decrement the ref count of the
3794     * interpreter's result object after calling Tcl_SetResult since we
3795     * next store into that field directly.
3796     */
3797    
3798     if (result == TCL_OK) {
3799     *resultPtrPtr = iPtr->objResultPtr;
3800     Tcl_IncrRefCount(iPtr->objResultPtr);
3801    
3802     Tcl_SetObjResult(interp, saveObjPtr);
3803     }
3804     Tcl_DecrRefCount(saveObjPtr);
3805     return result;
3806     }
3807    
3808     /*
3809     *----------------------------------------------------------------------
3810     *
3811     * Tcl_CreateTrace --
3812     *
3813     * Arrange for a procedure to be called to trace command execution.
3814     *
3815     * Results:
3816     * The return value is a token for the trace, which may be passed
3817     * to Tcl_DeleteTrace to eliminate the trace.
3818     *
3819     * Side effects:
3820     * From now on, proc will be called just before a command procedure
3821     * is called to execute a Tcl command. Calls to proc will have the
3822     * following form:
3823     *
3824     * void
3825     * proc(clientData, interp, level, command, cmdProc, cmdClientData,
3826     * argc, argv)
3827     * ClientData clientData;
3828     * Tcl_Interp *interp;
3829     * int level;
3830     * char *command;
3831     * int (*cmdProc)();
3832     * ClientData cmdClientData;
3833     * int argc;
3834     * char **argv;
3835     * {
3836     * }
3837     *
3838     * The clientData and interp arguments to proc will be the same
3839     * as the corresponding arguments to this procedure. Level gives
3840     * the nesting level of command interpretation for this interpreter
3841     * (0 corresponds to top level). Command gives the ASCII text of
3842     * the raw command, cmdProc and cmdClientData give the procedure that
3843     * will be called to process the command and the ClientData value it
3844     * will receive, and argc and argv give the arguments to the
3845     * command, after any argument parsing and substitution. Proc
3846     * does not return a value.
3847     *
3848     *----------------------------------------------------------------------
3849     */
3850    
3851     Tcl_Trace
3852     Tcl_CreateTrace(interp, level, proc, clientData)
3853     Tcl_Interp *interp; /* Interpreter in which to create trace. */
3854     int level; /* Only call proc for commands at nesting
3855     * level<=argument level (1=>top level). */
3856     Tcl_CmdTraceProc *proc; /* Procedure to call before executing each
3857     * command. */
3858     ClientData clientData; /* Arbitrary value word to pass to proc. */
3859     {
3860     register Trace *tracePtr;
3861     register Interp *iPtr = (Interp *) interp;
3862    
3863     /*
3864     * Invalidate existing compiled code for this interpreter and arrange
3865     * (by setting the DONT_COMPILE_CMDS_INLINE flag) that when compiling
3866     * new code, no commands will be compiled inline (i.e., into an inline
3867     * sequence of instructions). We do this because commands that were
3868     * compiled inline will never result in a command trace being called.
3869     */
3870    
3871     iPtr->compileEpoch++;
3872     iPtr->flags |= DONT_COMPILE_CMDS_INLINE;
3873    
3874     tracePtr = (Trace *) ckalloc(sizeof(Trace));
3875     tracePtr->level = level;
3876     tracePtr->proc = proc;
3877     tracePtr->clientData = clientData;
3878     tracePtr->nextPtr = iPtr->tracePtr;
3879