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

Annotation of /projs/dtats/trunk/shared_source/c_tcl_base_7_5_w_mods/tclexecute.c

Parent Directory Parent Directory | Revision Log Revision Log


Revision 98 - (hide annotations) (download)
Sun Dec 18 00:57:31 2016 UTC (7 years, 7 months ago) by dashley
File MIME type: text/plain
File size: 151465 byte(s)
Reorganization.
1 dashley 71 /* $Header$ */
2     /*
3     * tclExecute.c --
4     *
5     * This file contains procedures that execute byte-compiled Tcl
6     * commands.
7     *
8     * Copyright (c) 1996-1997 Sun Microsystems, Inc.
9     *
10     * See the file "license.terms" for information on usage and redistribution
11     * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
12     *
13     * RCS: @(#) $Id: tclexecute.c,v 1.1.1.1 2001/06/13 04:38:49 dtashley Exp $
14     */
15    
16     #include "tclInt.h"
17     #include "tclCompile.h"
18    
19     #ifdef NO_FLOAT_H
20     # include "../compat/float.h"
21     #else
22     # include <float.h>
23     #endif
24     #ifndef TCL_NO_MATH
25     #include "tclMath.h"
26     #endif
27    
28     /*
29     * The stuff below is a bit of a hack so that this file can be used
30     * in environments that include no UNIX, i.e. no errno. Just define
31     * errno here.
32     */
33    
34     #ifndef TCL_GENERIC_ONLY
35     #include "tclPort.h"
36     #else
37     #define NO_ERRNO_H
38     #endif
39    
40     #ifdef NO_ERRNO_H
41     int errno;
42     #define EDOM 33
43     #define ERANGE 34
44     #endif
45    
46     /*
47     * Boolean flag indicating whether the Tcl bytecode interpreter has been
48     * initialized.
49     */
50    
51     static int execInitialized = 0;
52     TCL_DECLARE_MUTEX(execMutex)
53    
54     /*
55     * Variable that controls whether execution tracing is enabled and, if so,
56     * what level of tracing is desired:
57     * 0: no execution tracing
58     * 1: trace invocations of Tcl procs only
59     * 2: trace invocations of all (not compiled away) commands
60     * 3: display each instruction executed
61     * This variable is linked to the Tcl variable "tcl_traceExec".
62     */
63    
64     int tclTraceExec = 0;
65    
66     typedef struct ThreadSpecificData {
67     /*
68     * The following global variable is use to signal matherr that Tcl
69     * is responsible for the arithmetic, so errors can be handled in a
70     * fashion appropriate for Tcl. Zero means no Tcl math is in
71     * progress; non-zero means Tcl is doing math.
72     */
73    
74     int mathInProgress;
75    
76     } ThreadSpecificData;
77    
78     static Tcl_ThreadDataKey dataKey;
79    
80     /*
81     * The variable below serves no useful purpose except to generate
82     * a reference to matherr, so that the Tcl version of matherr is
83     * linked in rather than the system version. Without this reference
84     * the need for matherr won't be discovered during linking until after
85     * libtcl.a has been processed, so Tcl's version won't be used.
86     */
87    
88     #ifdef NEED_MATHERR
89     extern int matherr();
90     int (*tclMatherrPtr)() = matherr;
91     #endif
92    
93     /*
94     * Mapping from expression instruction opcodes to strings; used for error
95     * messages. Note that these entries must match the order and number of the
96     * expression opcodes (e.g., INST_LOR) in tclCompile.h.
97     */
98    
99     static char *operatorStrings[] = {
100     "||", "&&", "|", "^", "&", "==", "!=", "<", ">", "<=", ">=", "<<", ">>",
101     "+", "-", "*", "/", "%", "+", "-", "~", "!",
102     "BUILTIN FUNCTION", "FUNCTION"
103     };
104    
105     /*
106     * Mapping from Tcl result codes to strings; used for error and debugging
107     * messages.
108     */
109    
110     #ifdef TCL_COMPILE_DEBUG
111     static char *resultStrings[] = {
112     "TCL_OK", "TCL_ERROR", "TCL_RETURN", "TCL_BREAK", "TCL_CONTINUE"
113     };
114     #endif
115    
116     /*
117     * Macros for testing floating-point values for certain special cases. Test
118     * for not-a-number by comparing a value against itself; test for infinity
119     * by comparing against the largest floating-point value.
120     */
121    
122     #define IS_NAN(v) ((v) != (v))
123     #ifdef DBL_MAX
124     # define IS_INF(v) (((v) > DBL_MAX) || ((v) < -DBL_MAX))
125     #else
126     # define IS_INF(v) 0
127     #endif
128    
129     /*
130     * Macro to adjust the program counter and restart the instruction execution
131     * loop after each instruction is executed.
132     */
133    
134     #define ADJUST_PC(instBytes) \
135     pc += (instBytes); \
136     continue
137    
138     /*
139     * Macros used to cache often-referenced Tcl evaluation stack information
140     * in local variables. Note that a DECACHE_STACK_INFO()-CACHE_STACK_INFO()
141     * pair must surround any call inside TclExecuteByteCode (and a few other
142     * procedures that use this scheme) that could result in a recursive call
143     * to TclExecuteByteCode.
144     */
145    
146     #define CACHE_STACK_INFO() \
147     stackPtr = eePtr->stackPtr; \
148     stackTop = eePtr->stackTop
149    
150     #define DECACHE_STACK_INFO() \
151     eePtr->stackTop = stackTop
152    
153     /*
154     * Macros used to access items on the Tcl evaluation stack. PUSH_OBJECT
155     * increments the object's ref count since it makes the stack have another
156     * reference pointing to the object. However, POP_OBJECT does not decrement
157     * the ref count. This is because the stack may hold the only reference to
158     * the object, so the object would be destroyed if its ref count were
159     * decremented before the caller had a chance to, e.g., store it in a
160     * variable. It is the caller's responsibility to decrement the ref count
161     * when it is finished with an object.
162     *
163     * WARNING! It is essential that objPtr only appear once in the PUSH_OBJECT
164     * macro. The actual parameter might be an expression with side effects,
165     * and this ensures that it will be executed only once.
166     */
167    
168     #define PUSH_OBJECT(objPtr) \
169     Tcl_IncrRefCount(stackPtr[++stackTop] = (objPtr))
170    
171     #define POP_OBJECT() \
172     (stackPtr[stackTop--])
173    
174     /*
175     * Macros used to trace instruction execution. The macros TRACE,
176     * TRACE_WITH_OBJ, and O2S are only used inside TclExecuteByteCode.
177     * O2S is only used in TRACE* calls to get a string from an object.
178     */
179    
180     #ifdef TCL_COMPILE_DEBUG
181     #define TRACE(a) \
182     if (traceInstructions) { \
183     fprintf(stdout, "%2d: %2d (%u) %s ", iPtr->numLevels, stackTop, \
184     (unsigned int)(pc - codePtr->codeStart), \
185     GetOpcodeName(pc)); \
186     printf a; \
187     }
188     #define TRACE_WITH_OBJ(a, objPtr) \
189     if (traceInstructions) { \
190     fprintf(stdout, "%2d: %2d (%u) %s ", iPtr->numLevels, stackTop, \
191     (unsigned int)(pc - codePtr->codeStart), \
192     GetOpcodeName(pc)); \
193     printf a; \
194     TclPrintObject(stdout, (objPtr), 30); \
195     fprintf(stdout, "\n"); \
196     }
197     #define O2S(objPtr) \
198     Tcl_GetString(objPtr)
199     #else
200     #define TRACE(a)
201     #define TRACE_WITH_OBJ(a, objPtr)
202     #define O2S(objPtr)
203     #endif /* TCL_COMPILE_DEBUG */
204    
205     /*
206     * Declarations for local procedures to this file:
207     */
208    
209     static void CallTraceProcedure _ANSI_ARGS_((Tcl_Interp *interp,
210     Trace *tracePtr, Command *cmdPtr,
211     char *command, int numChars,
212     int objc, Tcl_Obj *objv[]));
213     static void DupCmdNameInternalRep _ANSI_ARGS_((Tcl_Obj *objPtr,
214     Tcl_Obj *copyPtr));
215     static int ExprAbsFunc _ANSI_ARGS_((Tcl_Interp *interp,
216     ExecEnv *eePtr, ClientData clientData));
217     static int ExprBinaryFunc _ANSI_ARGS_((Tcl_Interp *interp,
218     ExecEnv *eePtr, ClientData clientData));
219     static int ExprCallMathFunc _ANSI_ARGS_((Tcl_Interp *interp,
220     ExecEnv *eePtr, int objc, Tcl_Obj **objv));
221     static int ExprDoubleFunc _ANSI_ARGS_((Tcl_Interp *interp,
222     ExecEnv *eePtr, ClientData clientData));
223     static int ExprIntFunc _ANSI_ARGS_((Tcl_Interp *interp,
224     ExecEnv *eePtr, ClientData clientData));
225     static int ExprRandFunc _ANSI_ARGS_((Tcl_Interp *interp,
226     ExecEnv *eePtr, ClientData clientData));
227     static int ExprRoundFunc _ANSI_ARGS_((Tcl_Interp *interp,
228     ExecEnv *eePtr, ClientData clientData));
229     static int ExprSrandFunc _ANSI_ARGS_((Tcl_Interp *interp,
230     ExecEnv *eePtr, ClientData clientData));
231     static int ExprUnaryFunc _ANSI_ARGS_((Tcl_Interp *interp,
232     ExecEnv *eePtr, ClientData clientData));
233     #ifdef TCL_COMPILE_STATS
234     static int EvalStatsCmd _ANSI_ARGS_((ClientData clientData,
235     Tcl_Interp *interp, int argc, char **argv));
236     #endif
237     static void FreeCmdNameInternalRep _ANSI_ARGS_((
238     Tcl_Obj *objPtr));
239     #ifdef TCL_COMPILE_DEBUG
240     static char * GetOpcodeName _ANSI_ARGS_((unsigned char *pc));
241     #endif
242     static ExceptionRange * GetExceptRangeForPc _ANSI_ARGS_((unsigned char *pc,
243     int catchOnly, ByteCode* codePtr));
244     static char * GetSrcInfoForPc _ANSI_ARGS_((unsigned char *pc,
245     ByteCode* codePtr, int *lengthPtr));
246     static void GrowEvaluationStack _ANSI_ARGS_((ExecEnv *eePtr));
247     static void IllegalExprOperandType _ANSI_ARGS_((
248     Tcl_Interp *interp, unsigned char *pc,
249     Tcl_Obj *opndPtr));
250     static void InitByteCodeExecution _ANSI_ARGS_((
251     Tcl_Interp *interp));
252     #ifdef TCL_COMPILE_DEBUG
253     static void PrintByteCodeInfo _ANSI_ARGS_((ByteCode *codePtr));
254     #endif
255     static int SetCmdNameFromAny _ANSI_ARGS_((Tcl_Interp *interp,
256     Tcl_Obj *objPtr));
257     #ifdef TCL_COMPILE_DEBUG
258     static char * StringForResultCode _ANSI_ARGS_((int result));
259     static void ValidatePcAndStackTop _ANSI_ARGS_((
260     ByteCode *codePtr, unsigned char *pc,
261     int stackTop, int stackLowerBound,
262     int stackUpperBound));
263     #endif
264     static int VerifyExprObjType _ANSI_ARGS_((Tcl_Interp *interp,
265     Tcl_Obj *objPtr));
266    
267     /*
268     * Table describing the built-in math functions. Entries in this table are
269     * indexed by the values of the INST_CALL_BUILTIN_FUNC instruction's
270     * operand byte.
271     */
272    
273     BuiltinFunc builtinFuncTable[] = {
274     #ifndef TCL_NO_MATH
275     {"acos", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) acos},
276     {"asin", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) asin},
277     {"atan", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) atan},
278     {"atan2", 2, {TCL_DOUBLE, TCL_DOUBLE}, ExprBinaryFunc, (ClientData) atan2},
279     {"ceil", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) ceil},
280     {"cos", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) cos},
281     {"cosh", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) cosh},
282     {"exp", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) exp},
283     {"floor", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) floor},
284     {"fmod", 2, {TCL_DOUBLE, TCL_DOUBLE}, ExprBinaryFunc, (ClientData) fmod},
285     {"hypot", 2, {TCL_DOUBLE, TCL_DOUBLE}, ExprBinaryFunc, (ClientData) hypot},
286     {"log", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) log},
287     {"log10", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) log10},
288     {"pow", 2, {TCL_DOUBLE, TCL_DOUBLE}, ExprBinaryFunc, (ClientData) pow},
289     {"sin", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) sin},
290     {"sinh", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) sinh},
291     {"sqrt", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) sqrt},
292     {"tan", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) tan},
293     {"tanh", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) tanh},
294     #endif
295     {"abs", 1, {TCL_EITHER}, ExprAbsFunc, 0},
296     {"double", 1, {TCL_EITHER}, ExprDoubleFunc, 0},
297     {"int", 1, {TCL_EITHER}, ExprIntFunc, 0},
298     {"rand", 0, {TCL_EITHER}, ExprRandFunc, 0}, /* NOTE: rand takes no args. */
299     {"round", 1, {TCL_EITHER}, ExprRoundFunc, 0},
300     {"srand", 1, {TCL_INT}, ExprSrandFunc, 0},
301     {0},
302     };
303    
304     /*
305     * The structure below defines the command name Tcl object type by means of
306     * procedures that can be invoked by generic object code. Objects of this
307     * type cache the Command pointer that results from looking up command names
308     * in the command hashtable. Such objects appear as the zeroth ("command
309     * name") argument in a Tcl command.
310     */
311    
312     Tcl_ObjType tclCmdNameType = {
313     "cmdName", /* name */
314     FreeCmdNameInternalRep, /* freeIntRepProc */
315     DupCmdNameInternalRep, /* dupIntRepProc */
316     (Tcl_UpdateStringProc *) NULL, /* updateStringProc */
317     SetCmdNameFromAny /* setFromAnyProc */
318     };
319    
320     /*
321     *----------------------------------------------------------------------
322     *
323     * InitByteCodeExecution --
324     *
325     * This procedure is called once to initialize the Tcl bytecode
326     * interpreter.
327     *
328     * Results:
329     * None.
330     *
331     * Side effects:
332     * This procedure initializes the array of instruction names. If
333     * compiling with the TCL_COMPILE_STATS flag, it initializes the
334     * array that counts the executions of each instruction and it
335     * creates the "evalstats" command. It also registers the command name
336     * Tcl_ObjType. It also establishes the link between the Tcl
337     * "tcl_traceExec" and C "tclTraceExec" variables.
338     *
339     *----------------------------------------------------------------------
340     */
341    
342     static void
343     InitByteCodeExecution(interp)
344     Tcl_Interp *interp; /* Interpreter for which the Tcl variable
345     * "tcl_traceExec" is linked to control
346     * instruction tracing. */
347     {
348     Tcl_RegisterObjType(&tclCmdNameType);
349     if (Tcl_LinkVar(interp, "tcl_traceExec", (char *) &tclTraceExec,
350     TCL_LINK_INT) != TCL_OK) {
351     panic("InitByteCodeExecution: can't create link for tcl_traceExec variable");
352     }
353    
354     #ifdef TCL_COMPILE_STATS
355     Tcl_CreateCommand(interp, "evalstats", EvalStatsCmd,
356     (ClientData) NULL, (Tcl_CmdDeleteProc *) NULL);
357     #endif /* TCL_COMPILE_STATS */
358     }
359    
360     /*
361     *----------------------------------------------------------------------
362     *
363     * TclCreateExecEnv --
364     *
365     * This procedure creates a new execution environment for Tcl bytecode
366     * execution. An ExecEnv points to a Tcl evaluation stack. An ExecEnv
367     * is typically created once for each Tcl interpreter (Interp
368     * structure) and recursively passed to TclExecuteByteCode to execute
369     * ByteCode sequences for nested commands.
370     *
371     * Results:
372     * A newly allocated ExecEnv is returned. This points to an empty
373     * evaluation stack of the standard initial size.
374     *
375     * Side effects:
376     * The bytecode interpreter is also initialized here, as this
377     * procedure will be called before any call to TclExecuteByteCode.
378     *
379     *----------------------------------------------------------------------
380     */
381    
382     #define TCL_STACK_INITIAL_SIZE 2000
383    
384     ExecEnv *
385     TclCreateExecEnv(interp)
386     Tcl_Interp *interp; /* Interpreter for which the execution
387     * environment is being created. */
388     {
389     ExecEnv *eePtr = (ExecEnv *) ckalloc(sizeof(ExecEnv));
390    
391     eePtr->stackPtr = (Tcl_Obj **)
392     ckalloc((unsigned) (TCL_STACK_INITIAL_SIZE * sizeof(Tcl_Obj *)));
393     eePtr->stackTop = -1;
394     eePtr->stackEnd = (TCL_STACK_INITIAL_SIZE - 1);
395    
396     Tcl_MutexLock(&execMutex);
397     if (!execInitialized) {
398     TclInitAuxDataTypeTable();
399     InitByteCodeExecution(interp);
400     execInitialized = 1;
401     }
402     Tcl_MutexUnlock(&execMutex);
403    
404     return eePtr;
405     }
406     #undef TCL_STACK_INITIAL_SIZE
407    
408     /*
409     *----------------------------------------------------------------------
410     *
411     * TclDeleteExecEnv --
412     *
413     * Frees the storage for an ExecEnv.
414     *
415     * Results:
416     * None.
417     *
418     * Side effects:
419     * Storage for an ExecEnv and its contained storage (e.g. the
420     * evaluation stack) is freed.
421     *
422     *----------------------------------------------------------------------
423     */
424    
425     void
426     TclDeleteExecEnv(eePtr)
427     ExecEnv *eePtr; /* Execution environment to free. */
428     {
429     ckfree((char *) eePtr->stackPtr);
430     ckfree((char *) eePtr);
431     }
432    
433     /*
434     *----------------------------------------------------------------------
435     *
436     * TclFinalizeExecution --
437     *
438     * Finalizes the execution environment setup so that it can be
439     * later reinitialized.
440     *
441     * Results:
442     * None.
443     *
444     * Side effects:
445     * After this call, the next time TclCreateExecEnv will be called
446     * it will call InitByteCodeExecution.
447     *
448     *----------------------------------------------------------------------
449     */
450    
451     void
452     TclFinalizeExecution()
453     {
454     Tcl_MutexLock(&execMutex);
455     execInitialized = 0;
456     Tcl_MutexUnlock(&execMutex);
457     TclFinalizeAuxDataTypeTable();
458     }
459    
460     /*
461     *----------------------------------------------------------------------
462     *
463     * GrowEvaluationStack --
464     *
465     * This procedure grows a Tcl evaluation stack stored in an ExecEnv.
466     *
467     * Results:
468     * None.
469     *
470     * Side effects:
471     * The size of the evaluation stack is doubled.
472     *
473     *----------------------------------------------------------------------
474     */
475    
476     static void
477     GrowEvaluationStack(eePtr)
478     register ExecEnv *eePtr; /* Points to the ExecEnv with an evaluation
479     * stack to enlarge. */
480     {
481     /*
482     * The current Tcl stack elements are stored from eePtr->stackPtr[0]
483     * to eePtr->stackPtr[eePtr->stackEnd] (inclusive).
484     */
485    
486     int currElems = (eePtr->stackEnd + 1);
487     int newElems = 2*currElems;
488     int currBytes = currElems * sizeof(Tcl_Obj *);
489     int newBytes = 2*currBytes;
490     Tcl_Obj **newStackPtr = (Tcl_Obj **) ckalloc((unsigned) newBytes);
491    
492     /*
493     * Copy the existing stack items to the new stack space, free the old
494     * storage if appropriate, and mark new space as malloc'ed.
495     */
496    
497     memcpy((VOID *) newStackPtr, (VOID *) eePtr->stackPtr,
498     (size_t) currBytes);
499     ckfree((char *) eePtr->stackPtr);
500     eePtr->stackPtr = newStackPtr;
501     eePtr->stackEnd = (newElems - 1); /* i.e. index of last usable item */
502     }
503    
504     /*
505     *----------------------------------------------------------------------
506     *
507     * TclExecuteByteCode --
508     *
509     * This procedure executes the instructions of a ByteCode structure.
510     * It returns when a "done" instruction is executed or an error occurs.
511     *
512     * Results:
513     * The return value is one of the return codes defined in tcl.h
514     * (such as TCL_OK), and interp->objResultPtr refers to a Tcl object
515     * that either contains the result of executing the code or an
516     * error message.
517     *
518     * Side effects:
519     * Almost certainly, depending on the ByteCode's instructions.
520     *
521     *----------------------------------------------------------------------
522     */
523    
524     int
525     TclExecuteByteCode(interp, codePtr)
526     Tcl_Interp *interp; /* Token for command interpreter. */
527     ByteCode *codePtr; /* The bytecode sequence to interpret. */
528     {
529     Interp *iPtr = (Interp *) interp;
530     ExecEnv *eePtr = iPtr->execEnvPtr;
531     /* Points to the execution environment. */
532     register Tcl_Obj **stackPtr = eePtr->stackPtr;
533     /* Cached evaluation stack base pointer. */
534     register int stackTop = eePtr->stackTop;
535     /* Cached top index of evaluation stack. */
536     register unsigned char *pc = codePtr->codeStart;
537     /* The current program counter. */
538     int opnd; /* Current instruction's operand byte. */
539     int pcAdjustment; /* Hold pc adjustment after instruction. */
540     int initStackTop = stackTop;/* Stack top at start of execution. */
541     ExceptionRange *rangePtr; /* Points to closest loop or catch exception
542     * range enclosing the pc. Used by various
543     * instructions and processCatch to
544     * process break, continue, and errors. */
545     int result = TCL_OK; /* Return code returned after execution. */
546     int traceInstructions = (tclTraceExec == 3);
547     Tcl_Obj *valuePtr, *value2Ptr, *objPtr;
548     char *bytes;
549     int length;
550     long i;
551    
552     /*
553     * This procedure uses a stack to hold information about catch commands.
554     * This information is the current operand stack top when starting to
555     * execute the code for each catch command. It starts out with stack-
556     * allocated space but uses dynamically-allocated storage if needed.
557     */
558    
559     #define STATIC_CATCH_STACK_SIZE 4
560     int (catchStackStorage[STATIC_CATCH_STACK_SIZE]);
561     int *catchStackPtr = catchStackStorage;
562     int catchTop = -1;
563    
564     #ifdef TCL_COMPILE_DEBUG
565     if (tclTraceExec >= 2) {
566     PrintByteCodeInfo(codePtr);
567     fprintf(stdout, " Starting stack top=%d\n", eePtr->stackTop);
568     fflush(stdout);
569     }
570     #endif
571    
572     #ifdef TCL_COMPILE_STATS
573     iPtr->stats.numExecutions++;
574     #endif
575    
576     /*
577     * Make sure the catch stack is large enough to hold the maximum number
578     * of catch commands that could ever be executing at the same time. This
579     * will be no more than the exception range array's depth.
580     */
581    
582     if (codePtr->maxExceptDepth > STATIC_CATCH_STACK_SIZE) {
583     catchStackPtr = (int *)
584     ckalloc(codePtr->maxExceptDepth * sizeof(int));
585     }
586    
587     /*
588     * Make sure the stack has enough room to execute this ByteCode.
589     */
590    
591     while ((stackTop + codePtr->maxStackDepth) > eePtr->stackEnd) {
592     GrowEvaluationStack(eePtr);
593     stackPtr = eePtr->stackPtr;
594     }
595    
596     /*
597     * Loop executing instructions until a "done" instruction, a TCL_RETURN,
598     * or some error.
599     */
600    
601     for (;;) {
602     #ifdef TCL_COMPILE_DEBUG
603     ValidatePcAndStackTop(codePtr, pc, stackTop, initStackTop,
604     eePtr->stackEnd);
605     #else /* not TCL_COMPILE_DEBUG */
606     if (traceInstructions) {
607     fprintf(stdout, "%2d: %2d ", iPtr->numLevels, stackTop);
608     TclPrintInstruction(codePtr, pc);
609     fflush(stdout);
610     }
611     #endif /* TCL_COMPILE_DEBUG */
612    
613     #ifdef TCL_COMPILE_STATS
614     iPtr->stats.instructionCount[*pc]++;
615     #endif
616     switch (*pc) {
617     case INST_DONE:
618     /*
619     * Pop the topmost object from the stack, set the interpreter's
620     * object result to point to it, and return.
621     */
622     valuePtr = POP_OBJECT();
623     Tcl_SetObjResult(interp, valuePtr);
624     TclDecrRefCount(valuePtr);
625     if (stackTop != initStackTop) {
626     fprintf(stderr, "\nTclExecuteByteCode: done instruction at pc %u: stack top %d != entry stack top %d\n",
627     (unsigned int)(pc - codePtr->codeStart),
628     (unsigned int) stackTop,
629     (unsigned int) initStackTop);
630     panic("TclExecuteByteCode execution failure: end stack top != start stack top");
631     }
632     TRACE_WITH_OBJ(("=> return code=%d, result=", result),
633     iPtr->objResultPtr);
634     #ifdef TCL_COMPILE_DEBUG
635     if (traceInstructions) {
636     fprintf(stdout, "\n");
637     }
638     #endif
639     goto done;
640    
641     case INST_PUSH1:
642     #ifdef TCL_COMPILE_DEBUG
643     valuePtr = codePtr->objArrayPtr[TclGetUInt1AtPtr(pc+1)];
644     PUSH_OBJECT(valuePtr);
645     TRACE_WITH_OBJ(("%u => ", TclGetInt1AtPtr(pc+1)), valuePtr);
646     #else
647     PUSH_OBJECT(codePtr->objArrayPtr[TclGetUInt1AtPtr(pc+1)]);
648     #endif /* TCL_COMPILE_DEBUG */
649     ADJUST_PC(2);
650    
651     case INST_PUSH4:
652     valuePtr = codePtr->objArrayPtr[TclGetUInt4AtPtr(pc+1)];
653     PUSH_OBJECT(valuePtr);
654     TRACE_WITH_OBJ(("%u => ", TclGetUInt4AtPtr(pc+1)), valuePtr);
655     ADJUST_PC(5);
656    
657     case INST_POP:
658     valuePtr = POP_OBJECT();
659     TRACE_WITH_OBJ(("=> discarding "), valuePtr);
660     TclDecrRefCount(valuePtr); /* finished with pop'ed object. */
661     ADJUST_PC(1);
662    
663     case INST_DUP:
664     valuePtr = stackPtr[stackTop];
665     PUSH_OBJECT(Tcl_DuplicateObj(valuePtr));
666     TRACE_WITH_OBJ(("=> "), valuePtr);
667     ADJUST_PC(1);
668    
669     case INST_CONCAT1:
670     opnd = TclGetUInt1AtPtr(pc+1);
671     {
672     Tcl_Obj *concatObjPtr;
673     int totalLen = 0;
674    
675     /*
676     * Concatenate strings (with no separators) from the top
677     * opnd items on the stack starting with the deepest item.
678     * First, determine how many characters are needed.
679     */
680    
681     for (i = (stackTop - (opnd-1)); i <= stackTop; i++) {
682     bytes = Tcl_GetStringFromObj(stackPtr[i], &length);
683     if (bytes != NULL) {
684     totalLen += length;
685     }
686     }
687    
688     /*
689     * Initialize the new append string object by appending the
690     * strings of the opnd stack objects. Also pop the objects.
691     */
692    
693     TclNewObj(concatObjPtr);
694     if (totalLen > 0) {
695     char *p = (char *) ckalloc((unsigned) (totalLen + 1));
696     concatObjPtr->bytes = p;
697     concatObjPtr->length = totalLen;
698     for (i = (stackTop - (opnd-1)); i <= stackTop; i++) {
699     valuePtr = stackPtr[i];
700     bytes = Tcl_GetStringFromObj(valuePtr, &length);
701     if (bytes != NULL) {
702     memcpy((VOID *) p, (VOID *) bytes,
703     (size_t) length);
704     p += length;
705     }
706     TclDecrRefCount(valuePtr);
707     }
708     *p = '\0';
709     } else {
710     for (i = (stackTop - (opnd-1)); i <= stackTop; i++) {
711     Tcl_DecrRefCount(stackPtr[i]);
712     }
713     }
714     stackTop -= opnd;
715    
716     PUSH_OBJECT(concatObjPtr);
717     TRACE_WITH_OBJ(("%u => ", opnd), concatObjPtr);
718     ADJUST_PC(2);
719     }
720    
721     case INST_INVOKE_STK4:
722     opnd = TclGetUInt4AtPtr(pc+1);
723     pcAdjustment = 5;
724     goto doInvocation;
725    
726     case INST_INVOKE_STK1:
727     opnd = TclGetUInt1AtPtr(pc+1);
728     pcAdjustment = 2;
729    
730     doInvocation:
731     {
732     int objc = opnd; /* The number of arguments. */
733     Tcl_Obj **objv; /* The array of argument objects. */
734     Command *cmdPtr; /* Points to command's Command struct. */
735     int newPcOffset; /* New inst offset for break, continue. */
736     #ifdef TCL_COMPILE_DEBUG
737     int isUnknownCmd = 0;
738     char cmdNameBuf[21];
739     #endif /* TCL_COMPILE_DEBUG */
740    
741     /*
742     * If the interpreter was deleted, return an error.
743     */
744    
745     if (iPtr->flags & DELETED) {
746     Tcl_ResetResult(interp);
747     Tcl_AppendToObj(Tcl_GetObjResult(interp),
748     "attempt to call eval in deleted interpreter", -1);
749     Tcl_SetErrorCode(interp, "CORE", "IDELETE",
750     "attempt to call eval in deleted interpreter",
751     (char *) NULL);
752     result = TCL_ERROR;
753     goto checkForCatch;
754     }
755    
756     /*
757     * Find the procedure to execute this command. If the
758     * command is not found, handle it with the "unknown" proc.
759     */
760    
761     objv = &(stackPtr[stackTop - (objc-1)]);
762     cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, objv[0]);
763     if (cmdPtr == NULL) {
764     cmdPtr = (Command *) Tcl_FindCommand(interp, "unknown",
765     (Tcl_Namespace *) NULL, TCL_GLOBAL_ONLY);
766     if (cmdPtr == NULL) {
767     Tcl_ResetResult(interp);
768     Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
769     "invalid command name \"",
770     Tcl_GetString(objv[0]), "\"",
771     (char *) NULL);
772     TRACE(("%u => unknown proc not found: ", objc));
773     result = TCL_ERROR;
774     goto checkForCatch;
775     }
776     #ifdef TCL_COMPILE_DEBUG
777     isUnknownCmd = 1;
778     #endif /*TCL_COMPILE_DEBUG*/
779     stackTop++; /* need room for new inserted objv[0] */
780     for (i = objc-1; i >= 0; i--) {
781     objv[i+1] = objv[i];
782     }
783     objc++;
784     objv[0] = Tcl_NewStringObj("unknown", -1);
785     Tcl_IncrRefCount(objv[0]);
786     }
787    
788     /*
789     * Call any trace procedures.
790     */
791    
792     if (iPtr->tracePtr != NULL) {
793     Trace *tracePtr, *nextTracePtr;
794    
795     for (tracePtr = iPtr->tracePtr; tracePtr != NULL;
796     tracePtr = nextTracePtr) {
797     nextTracePtr = tracePtr->nextPtr;
798     if (iPtr->numLevels <= tracePtr->level) {
799     int numChars;
800     char *cmd = GetSrcInfoForPc(pc, codePtr,
801     &numChars);
802     if (cmd != NULL) {
803     DECACHE_STACK_INFO();
804     CallTraceProcedure(interp, tracePtr, cmdPtr,
805     cmd, numChars, objc, objv);
806     CACHE_STACK_INFO();
807     }
808     }
809     }
810     }
811    
812     /*
813     * Finally, invoke the command's Tcl_ObjCmdProc. First reset
814     * the interpreter's string and object results to their
815     * default empty values since they could have gotten changed
816     * by earlier invocations.
817     */
818    
819     Tcl_ResetResult(interp);
820     if (tclTraceExec >= 2) {
821     #ifdef TCL_COMPILE_DEBUG
822     if (traceInstructions) {
823     strncpy(cmdNameBuf, Tcl_GetString(objv[0]), 20);
824     TRACE(("%u => call ", (isUnknownCmd? objc-1:objc)));
825     } else {
826     fprintf(stdout, "%d: (%u) invoking ",
827     iPtr->numLevels,
828     (unsigned int)(pc - codePtr->codeStart));
829     }
830     for (i = 0; i < objc; i++) {
831     TclPrintObject(stdout, objv[i], 15);
832     fprintf(stdout, " ");
833     }
834     fprintf(stdout, "\n");
835     fflush(stdout);
836     #else /* TCL_COMPILE_DEBUG */
837     fprintf(stdout, "%d: (%u) invoking %s\n",
838     iPtr->numLevels,
839     (unsigned int)(pc - codePtr->codeStart),
840     Tcl_GetString(objv[0]));
841     #endif /*TCL_COMPILE_DEBUG*/
842     }
843    
844     iPtr->cmdCount++;
845     DECACHE_STACK_INFO();
846     result = (*cmdPtr->objProc)(cmdPtr->objClientData, interp,
847     objc, objv);
848     if (Tcl_AsyncReady()) {
849     result = Tcl_AsyncInvoke(interp, result);
850     }
851     CACHE_STACK_INFO();
852    
853     /*
854     * If the interpreter has a non-empty string result, the
855     * result object is either empty or stale because some
856     * procedure set interp->result directly. If so, move the
857     * string result to the result object, then reset the
858     * string result.
859     */
860    
861     if (*(iPtr->result) != 0) {
862     (void) Tcl_GetObjResult(interp);
863     }
864    
865     /*
866     * Pop the objc top stack elements and decrement their ref
867     * counts.
868     */
869    
870     for (i = 0; i < objc; i++) {
871     valuePtr = stackPtr[stackTop];
872     TclDecrRefCount(valuePtr);
873     stackTop--;
874     }
875    
876     /*
877     * Process the result of the Tcl_ObjCmdProc call.
878     */
879    
880     switch (result) {
881     case TCL_OK:
882     /*
883     * Push the call's object result and continue execution
884     * with the next instruction.
885     */
886     PUSH_OBJECT(Tcl_GetObjResult(interp));
887     TRACE_WITH_OBJ(("%u => ...after \"%.20s\", result=",
888     objc, cmdNameBuf), Tcl_GetObjResult(interp));
889     ADJUST_PC(pcAdjustment);
890    
891     case TCL_BREAK:
892     case TCL_CONTINUE:
893     /*
894     * The invoked command requested a break or continue.
895     * Find the closest enclosing loop or catch exception
896     * range, if any. If a loop is found, terminate its
897     * execution or skip to its next iteration. If the
898     * closest is a catch exception range, jump to its
899     * catchOffset. If no enclosing range is found, stop
900     * execution and return the TCL_BREAK or TCL_CONTINUE.
901     */
902     rangePtr = GetExceptRangeForPc(pc, /*catchOnly*/ 0,
903     codePtr);
904     if (rangePtr == NULL) {
905     TRACE(("%u => ... after \"%.20s\", no encl. loop or catch, returning %s\n",
906     objc, cmdNameBuf,
907     StringForResultCode(result)));
908     goto abnormalReturn; /* no catch exists to check */
909     }
910     newPcOffset = 0;
911     switch (rangePtr->type) {
912     case LOOP_EXCEPTION_RANGE:
913     if (result == TCL_BREAK) {
914     newPcOffset = rangePtr->breakOffset;
915     } else if (rangePtr->continueOffset == -1) {
916     TRACE(("%u => ... after \"%.20s\", %s, loop w/o continue, checking for catch\n",
917     objc, cmdNameBuf,
918     StringForResultCode(result)));
919     goto checkForCatch;
920     } else {
921     newPcOffset = rangePtr->continueOffset;
922     }
923     TRACE(("%u => ... after \"%.20s\", %s, range at %d, new pc %d\n",
924     objc, cmdNameBuf,
925     StringForResultCode(result),
926     rangePtr->codeOffset, newPcOffset));
927     break;
928     case CATCH_EXCEPTION_RANGE:
929     TRACE(("%u => ... after \"%.20s\", %s...\n",
930     objc, cmdNameBuf,
931     StringForResultCode(result)));
932     goto processCatch; /* it will use rangePtr */
933     default:
934     panic("TclExecuteByteCode: bad ExceptionRange type\n");
935     }
936     result = TCL_OK;
937     pc = (codePtr->codeStart + newPcOffset);
938     continue; /* restart outer instruction loop at pc */
939    
940     case TCL_ERROR:
941     /*
942     * The invoked command returned an error. Look for an
943     * enclosing catch exception range, if any.
944     */
945     TRACE_WITH_OBJ(("%u => ... after \"%.20s\", TCL_ERROR ",
946     objc, cmdNameBuf), Tcl_GetObjResult(interp));
947     goto checkForCatch;
948    
949     case TCL_RETURN:
950     /*
951     * The invoked command requested that the current
952     * procedure stop execution and return. First check
953     * for an enclosing catch exception range, if any.
954     */
955     TRACE(("%u => ... after \"%.20s\", TCL_RETURN\n",
956     objc, cmdNameBuf));
957     goto checkForCatch;
958    
959     default:
960     TRACE_WITH_OBJ(("%u => ... after \"%.20s\", OTHER RETURN CODE %d ",
961     objc, cmdNameBuf, result),
962     Tcl_GetObjResult(interp));
963     goto checkForCatch;
964     }
965     }
966    
967     case INST_EVAL_STK:
968     objPtr = POP_OBJECT();
969     DECACHE_STACK_INFO();
970     result = Tcl_EvalObjEx(interp, objPtr, 0);
971     CACHE_STACK_INFO();
972     if (result == TCL_OK) {
973     /*
974     * Normal return; push the eval's object result.
975     */
976     PUSH_OBJECT(Tcl_GetObjResult(interp));
977     TRACE_WITH_OBJ(("\"%.30s\" => ", O2S(objPtr)),
978     Tcl_GetObjResult(interp));
979     TclDecrRefCount(objPtr);
980     ADJUST_PC(1);
981     } else if ((result == TCL_BREAK) || (result == TCL_CONTINUE)) {
982     /*
983     * Find the closest enclosing loop or catch exception range,
984     * if any. If a loop is found, terminate its execution or
985     * skip to its next iteration. If the closest is a catch
986     * exception range, jump to its catchOffset. If no enclosing
987     * range is found, stop execution and return that same
988     * TCL_BREAK or TCL_CONTINUE.
989     */
990    
991     int newPcOffset = 0; /* Pc offset computed during break,
992     * continue, error processing. Init.
993     * to avoid compiler warning. */
994    
995     rangePtr = GetExceptRangeForPc(pc, /*catchOnly*/ 0,
996     codePtr);
997     if (rangePtr == NULL) {
998     TRACE(("\"%.30s\" => no encl. loop or catch, returning %s\n",
999     O2S(objPtr), StringForResultCode(result)));
1000     Tcl_DecrRefCount(objPtr);
1001     goto abnormalReturn; /* no catch exists to check */
1002     }
1003     switch (rangePtr->type) {
1004     case LOOP_EXCEPTION_RANGE:
1005     if (result == TCL_BREAK) {
1006     newPcOffset = rangePtr->breakOffset;
1007     } else if (rangePtr->continueOffset == -1) {
1008     TRACE(("\"%.30s\" => %s, loop w/o continue, checking for catch\n",
1009     O2S(objPtr), StringForResultCode(result)));
1010     Tcl_DecrRefCount(objPtr);
1011     goto checkForCatch;
1012     } else {
1013     newPcOffset = rangePtr->continueOffset;
1014     }
1015     result = TCL_OK;
1016     TRACE_WITH_OBJ(("\"%.30s\" => %s, range at %d, new pc %d ",
1017     O2S(objPtr), StringForResultCode(result),
1018     rangePtr->codeOffset, newPcOffset), valuePtr);
1019     break;
1020     case CATCH_EXCEPTION_RANGE:
1021     TRACE_WITH_OBJ(("\"%.30s\" => %s ",
1022     O2S(objPtr), StringForResultCode(result)),
1023     valuePtr);
1024     Tcl_DecrRefCount(objPtr);
1025     goto processCatch; /* it will use rangePtr */
1026     default:
1027     panic("TclExecuteByteCode: unrecognized ExceptionRange type %d\n", rangePtr->type);
1028     }
1029     Tcl_DecrRefCount(objPtr);
1030     pc = (codePtr->codeStart + newPcOffset);
1031     continue; /* restart outer instruction loop at pc */
1032     } else { /* eval returned TCL_ERROR, TCL_RETURN, unknown code */
1033     TRACE_WITH_OBJ(("\"%.30s\" => ERROR: ", O2S(objPtr)),
1034     Tcl_GetObjResult(interp));
1035     Tcl_DecrRefCount(objPtr);
1036     goto checkForCatch;
1037     }
1038    
1039     case INST_EXPR_STK:
1040     objPtr = POP_OBJECT();
1041     Tcl_ResetResult(interp);
1042     DECACHE_STACK_INFO();
1043     result = Tcl_ExprObj(interp, objPtr, &valuePtr);
1044     CACHE_STACK_INFO();
1045     if (result != TCL_OK) {
1046     TRACE_WITH_OBJ(("\"%.30s\" => ERROR: ",
1047     O2S(objPtr)), Tcl_GetObjResult(interp));
1048     Tcl_DecrRefCount(objPtr);
1049     goto checkForCatch;
1050     }
1051     stackPtr[++stackTop] = valuePtr; /* already has right refct */
1052     TRACE_WITH_OBJ(("\"%.30s\" => ", O2S(objPtr)), valuePtr);
1053     TclDecrRefCount(objPtr);
1054     ADJUST_PC(1);
1055    
1056     case INST_LOAD_SCALAR1:
1057     #ifdef TCL_COMPILE_DEBUG
1058     opnd = TclGetUInt1AtPtr(pc+1);
1059     DECACHE_STACK_INFO();
1060     valuePtr = TclGetIndexedScalar(interp, opnd,
1061     /*leaveErrorMsg*/ 1);
1062     CACHE_STACK_INFO();
1063     if (valuePtr == NULL) {
1064     TRACE_WITH_OBJ(("%u => ERROR: ", opnd),
1065     Tcl_GetObjResult(interp));
1066     result = TCL_ERROR;
1067     goto checkForCatch;
1068     }
1069     PUSH_OBJECT(valuePtr);
1070     TRACE_WITH_OBJ(("%u => ", opnd), valuePtr);
1071     #else /* TCL_COMPILE_DEBUG */
1072     DECACHE_STACK_INFO();
1073     opnd = TclGetUInt1AtPtr(pc+1);
1074     valuePtr = TclGetIndexedScalar(interp, opnd, /*leaveErrorMsg*/ 1);
1075     CACHE_STACK_INFO();
1076     if (valuePtr == NULL) {
1077     result = TCL_ERROR;
1078     goto checkForCatch;
1079     }
1080     PUSH_OBJECT(valuePtr);
1081     #endif /* TCL_COMPILE_DEBUG */
1082     ADJUST_PC(2);
1083    
1084     case INST_LOAD_SCALAR4:
1085     opnd = TclGetUInt4AtPtr(pc+1);
1086     DECACHE_STACK_INFO();
1087     valuePtr = TclGetIndexedScalar(interp, opnd,
1088     /*leaveErrorMsg*/ 1);
1089     CACHE_STACK_INFO();
1090     if (valuePtr == NULL) {
1091     TRACE_WITH_OBJ(("%u => ERROR: ", opnd),
1092     Tcl_GetObjResult(interp));
1093     result = TCL_ERROR;
1094     goto checkForCatch;
1095     }
1096     PUSH_OBJECT(valuePtr);
1097     TRACE_WITH_OBJ(("%u => ", opnd), valuePtr);
1098     ADJUST_PC(5);
1099    
1100     case INST_LOAD_SCALAR_STK:
1101     objPtr = POP_OBJECT(); /* scalar name */
1102     DECACHE_STACK_INFO();
1103     valuePtr = Tcl_ObjGetVar2(interp, objPtr, NULL, TCL_LEAVE_ERR_MSG);
1104     CACHE_STACK_INFO();
1105     if (valuePtr == NULL) {
1106     TRACE_WITH_OBJ(("\"%.30s\" => ERROR: ", O2S(objPtr)),
1107     Tcl_GetObjResult(interp));
1108     Tcl_DecrRefCount(objPtr);
1109     result = TCL_ERROR;
1110     goto checkForCatch;
1111     }
1112     PUSH_OBJECT(valuePtr);
1113     TRACE_WITH_OBJ(("\"%.30s\" => ", O2S(objPtr)), valuePtr);
1114     TclDecrRefCount(objPtr);
1115     ADJUST_PC(1);
1116    
1117     case INST_LOAD_ARRAY4:
1118     opnd = TclGetUInt4AtPtr(pc+1);
1119     pcAdjustment = 5;
1120     goto doLoadArray;
1121    
1122     case INST_LOAD_ARRAY1:
1123     opnd = TclGetUInt1AtPtr(pc+1);
1124     pcAdjustment = 2;
1125    
1126     doLoadArray:
1127     {
1128     Tcl_Obj *elemPtr = POP_OBJECT();
1129    
1130     DECACHE_STACK_INFO();
1131     valuePtr = TclGetElementOfIndexedArray(interp, opnd,
1132     elemPtr, /*leaveErrorMsg*/ 1);
1133     CACHE_STACK_INFO();
1134     if (valuePtr == NULL) {
1135     TRACE_WITH_OBJ(("%u \"%.30s\" => ERROR: ",
1136     opnd, O2S(elemPtr)), Tcl_GetObjResult(interp));
1137     Tcl_DecrRefCount(elemPtr);
1138     result = TCL_ERROR;
1139     goto checkForCatch;
1140     }
1141     PUSH_OBJECT(valuePtr);
1142     TRACE_WITH_OBJ(("%u \"%.30s\" => ",
1143     opnd, O2S(elemPtr)),valuePtr);
1144     TclDecrRefCount(elemPtr);
1145     }
1146     ADJUST_PC(pcAdjustment);
1147    
1148     case INST_LOAD_ARRAY_STK:
1149     {
1150     Tcl_Obj *elemPtr = POP_OBJECT();
1151    
1152     objPtr = POP_OBJECT(); /* array name */
1153     DECACHE_STACK_INFO();
1154     valuePtr = Tcl_ObjGetVar2(interp, objPtr, elemPtr,
1155     TCL_LEAVE_ERR_MSG);
1156     CACHE_STACK_INFO();
1157     if (valuePtr == NULL) {
1158     TRACE_WITH_OBJ(("\"%.30s(%.30s)\" => ERROR: ",
1159     O2S(objPtr), O2S(elemPtr)),
1160     Tcl_GetObjResult(interp));
1161     Tcl_DecrRefCount(objPtr);
1162     Tcl_DecrRefCount(elemPtr);
1163     result = TCL_ERROR;
1164     goto checkForCatch;
1165     }
1166     PUSH_OBJECT(valuePtr);
1167     TRACE_WITH_OBJ(("\"%.30s(%.30s)\" => ",
1168     O2S(objPtr), O2S(elemPtr)), valuePtr);
1169     TclDecrRefCount(objPtr);
1170     TclDecrRefCount(elemPtr);
1171     }
1172     ADJUST_PC(1);
1173    
1174     case INST_LOAD_STK:
1175     objPtr = POP_OBJECT(); /* variable name */
1176     DECACHE_STACK_INFO();
1177     valuePtr = Tcl_ObjGetVar2(interp, objPtr, NULL, TCL_LEAVE_ERR_MSG);
1178     CACHE_STACK_INFO();
1179     if (valuePtr == NULL) {
1180     TRACE_WITH_OBJ(("\"%.30s\" => ERROR: ",
1181     O2S(objPtr)), Tcl_GetObjResult(interp));
1182     Tcl_DecrRefCount(objPtr);
1183     result = TCL_ERROR;
1184     goto checkForCatch;
1185     }
1186     PUSH_OBJECT(valuePtr);
1187     TRACE_WITH_OBJ(("\"%.30s\" => ", O2S(objPtr)), valuePtr);
1188     TclDecrRefCount(objPtr);
1189     ADJUST_PC(1);
1190    
1191     case INST_STORE_SCALAR4:
1192     opnd = TclGetUInt4AtPtr(pc+1);
1193     pcAdjustment = 5;
1194     goto doStoreScalar;
1195    
1196     case INST_STORE_SCALAR1:
1197     opnd = TclGetUInt1AtPtr(pc+1);
1198     pcAdjustment = 2;
1199    
1200     doStoreScalar:
1201     valuePtr = POP_OBJECT();
1202     DECACHE_STACK_INFO();
1203     value2Ptr = TclSetIndexedScalar(interp, opnd, valuePtr,
1204     /*leaveErrorMsg*/ 1);
1205     CACHE_STACK_INFO();
1206     if (value2Ptr == NULL) {
1207     TRACE_WITH_OBJ(("%u <- \"%.30s\" => ERROR: ",
1208     opnd, O2S(valuePtr)), Tcl_GetObjResult(interp));
1209     Tcl_DecrRefCount(valuePtr);
1210     result = TCL_ERROR;
1211     goto checkForCatch;
1212     }
1213     PUSH_OBJECT(value2Ptr);
1214     TRACE_WITH_OBJ(("%u <- \"%.30s\" => ",
1215     opnd, O2S(valuePtr)), value2Ptr);
1216     TclDecrRefCount(valuePtr);
1217     ADJUST_PC(pcAdjustment);
1218    
1219     case INST_STORE_SCALAR_STK:
1220     valuePtr = POP_OBJECT();
1221     objPtr = POP_OBJECT(); /* scalar name */
1222     DECACHE_STACK_INFO();
1223     value2Ptr = Tcl_ObjSetVar2(interp, objPtr, NULL, valuePtr,
1224     TCL_LEAVE_ERR_MSG);
1225     CACHE_STACK_INFO();
1226     if (value2Ptr == NULL) {
1227     TRACE_WITH_OBJ(("\"%.30s\" <- \"%.30s\" => ERROR: ",
1228     O2S(objPtr), O2S(valuePtr)),
1229     Tcl_GetObjResult(interp));
1230     Tcl_DecrRefCount(objPtr);
1231     Tcl_DecrRefCount(valuePtr);
1232     result = TCL_ERROR;
1233     goto checkForCatch;
1234     }
1235     PUSH_OBJECT(value2Ptr);
1236     TRACE_WITH_OBJ(("\"%.30s\" <- \"%.30s\" => ",
1237     O2S(objPtr), O2S(valuePtr)), value2Ptr);
1238     TclDecrRefCount(objPtr);
1239     TclDecrRefCount(valuePtr);
1240     ADJUST_PC(1);
1241    
1242     case INST_STORE_ARRAY4:
1243     opnd = TclGetUInt4AtPtr(pc+1);
1244     pcAdjustment = 5;
1245     goto doStoreArray;
1246    
1247     case INST_STORE_ARRAY1:
1248     opnd = TclGetUInt1AtPtr(pc+1);
1249     pcAdjustment = 2;
1250    
1251     doStoreArray:
1252     {
1253     Tcl_Obj *elemPtr;
1254    
1255     valuePtr = POP_OBJECT();
1256     elemPtr = POP_OBJECT();
1257     DECACHE_STACK_INFO();
1258     value2Ptr = TclSetElementOfIndexedArray(interp, opnd,
1259     elemPtr, valuePtr, TCL_LEAVE_ERR_MSG);
1260     CACHE_STACK_INFO();
1261     if (value2Ptr == NULL) {
1262     TRACE_WITH_OBJ(("%u \"%.30s\" <- \"%.30s\" => ERROR: ",
1263     opnd, O2S(elemPtr), O2S(valuePtr)),
1264     Tcl_GetObjResult(interp));
1265     Tcl_DecrRefCount(elemPtr);
1266     Tcl_DecrRefCount(valuePtr);
1267     result = TCL_ERROR;
1268     goto checkForCatch;
1269     }
1270     PUSH_OBJECT(value2Ptr);
1271     TRACE_WITH_OBJ(("%u \"%.30s\" <- \"%.30s\" => ",
1272     opnd, O2S(elemPtr), O2S(valuePtr)), value2Ptr);
1273     TclDecrRefCount(elemPtr);
1274     TclDecrRefCount(valuePtr);
1275     }
1276     ADJUST_PC(pcAdjustment);
1277    
1278     case INST_STORE_ARRAY_STK:
1279     {
1280     Tcl_Obj *elemPtr;
1281    
1282     valuePtr = POP_OBJECT();
1283     elemPtr = POP_OBJECT();
1284     objPtr = POP_OBJECT(); /* array name */
1285     DECACHE_STACK_INFO();
1286     value2Ptr = Tcl_ObjSetVar2(interp, objPtr, elemPtr, valuePtr,
1287     TCL_LEAVE_ERR_MSG);
1288     CACHE_STACK_INFO();
1289     if (value2Ptr == NULL) {
1290     TRACE_WITH_OBJ(("\"%.30s(%.30s)\" <- \"%.30s\" => ERROR: ",
1291     O2S(objPtr), O2S(elemPtr), O2S(valuePtr)),
1292     Tcl_GetObjResult(interp));
1293     Tcl_DecrRefCount(objPtr);
1294     Tcl_DecrRefCount(elemPtr);
1295     Tcl_DecrRefCount(valuePtr);
1296     result = TCL_ERROR;
1297     goto checkForCatch;
1298     }
1299     PUSH_OBJECT(value2Ptr);
1300     TRACE_WITH_OBJ(("\"%.30s(%.30s)\" <- \"%.30s\" => ",
1301     O2S(objPtr), O2S(elemPtr), O2S(valuePtr)),
1302     value2Ptr);
1303     TclDecrRefCount(objPtr);
1304     TclDecrRefCount(elemPtr);
1305     TclDecrRefCount(valuePtr);
1306     }
1307     ADJUST_PC(1);
1308    
1309     case INST_STORE_STK:
1310     valuePtr = POP_OBJECT();
1311     objPtr = POP_OBJECT(); /* variable name */
1312     DECACHE_STACK_INFO();
1313     value2Ptr = Tcl_ObjSetVar2(interp, objPtr, NULL, valuePtr,
1314     TCL_LEAVE_ERR_MSG);
1315     CACHE_STACK_INFO();
1316     if (value2Ptr == NULL) {
1317     TRACE_WITH_OBJ(("\"%.30s\" <- \"%.30s\" => ERROR: ",
1318     O2S(objPtr), O2S(valuePtr)),
1319     Tcl_GetObjResult(interp));
1320     Tcl_DecrRefCount(objPtr);
1321     Tcl_DecrRefCount(valuePtr);
1322     result = TCL_ERROR;
1323     goto checkForCatch;
1324     }
1325     PUSH_OBJECT(value2Ptr);
1326     TRACE_WITH_OBJ(("\"%.30s\" <- \"%.30s\" => ",
1327     O2S(objPtr), O2S(valuePtr)), value2Ptr);
1328     TclDecrRefCount(objPtr);
1329     TclDecrRefCount(valuePtr);
1330     ADJUST_PC(1);
1331    
1332     case INST_INCR_SCALAR1:
1333     opnd = TclGetUInt1AtPtr(pc+1);
1334     valuePtr = POP_OBJECT();
1335     if (valuePtr->typePtr != &tclIntType) {
1336     result = tclIntType.setFromAnyProc(interp, valuePtr);
1337     if (result != TCL_OK) {
1338     TRACE_WITH_OBJ(("%u (by %s) => ERROR converting increment amount to int: ",
1339     opnd, O2S(valuePtr)), Tcl_GetObjResult(interp));
1340     Tcl_DecrRefCount(valuePtr);
1341     goto checkForCatch;
1342     }
1343     }
1344     i = valuePtr->internalRep.longValue;
1345     DECACHE_STACK_INFO();
1346     value2Ptr = TclIncrIndexedScalar(interp, opnd, i);
1347     CACHE_STACK_INFO();
1348     if (value2Ptr == NULL) {
1349     TRACE_WITH_OBJ(("%u (by %ld) => ERROR: ", opnd, i),
1350     Tcl_GetObjResult(interp));
1351     Tcl_DecrRefCount(valuePtr);
1352     result = TCL_ERROR;
1353     goto checkForCatch;
1354     }
1355     PUSH_OBJECT(value2Ptr);
1356     TRACE_WITH_OBJ(("%u (by %ld) => ", opnd, i), value2Ptr);
1357     TclDecrRefCount(valuePtr);
1358     ADJUST_PC(2);
1359    
1360     case INST_INCR_SCALAR_STK:
1361     case INST_INCR_STK:
1362     valuePtr = POP_OBJECT();
1363     objPtr = POP_OBJECT(); /* scalar name */
1364     if (valuePtr->typePtr != &tclIntType) {
1365     result = tclIntType.setFromAnyProc(interp, valuePtr);
1366     if (result != TCL_OK) {
1367     TRACE_WITH_OBJ(("\"%.30s\" (by %s) => ERROR converting increment amount to int: ",
1368     O2S(objPtr), O2S(valuePtr)),
1369     Tcl_GetObjResult(interp));
1370     Tcl_DecrRefCount(objPtr);
1371     Tcl_DecrRefCount(valuePtr);
1372     goto checkForCatch;
1373     }
1374     }
1375     i = valuePtr->internalRep.longValue;
1376     DECACHE_STACK_INFO();
1377     value2Ptr = TclIncrVar2(interp, objPtr, (Tcl_Obj *) NULL, i,
1378     TCL_LEAVE_ERR_MSG);
1379     CACHE_STACK_INFO();
1380     if (value2Ptr == NULL) {
1381     TRACE_WITH_OBJ(("\"%.30s\" (by %ld) => ERROR: ",
1382     O2S(objPtr), i), Tcl_GetObjResult(interp));
1383     Tcl_DecrRefCount(objPtr);
1384     Tcl_DecrRefCount(valuePtr);
1385     result = TCL_ERROR;
1386     goto checkForCatch;
1387     }
1388     PUSH_OBJECT(value2Ptr);
1389     TRACE_WITH_OBJ(("\"%.30s\" (by %ld) => ", O2S(objPtr), i),
1390     value2Ptr);
1391     Tcl_DecrRefCount(objPtr);
1392     Tcl_DecrRefCount(valuePtr);
1393     ADJUST_PC(1);
1394    
1395     case INST_INCR_ARRAY1:
1396     {
1397     Tcl_Obj *elemPtr;
1398    
1399     opnd = TclGetUInt1AtPtr(pc+1);
1400     valuePtr = POP_OBJECT();
1401     elemPtr = POP_OBJECT();
1402     if (valuePtr->typePtr != &tclIntType) {
1403     result = tclIntType.setFromAnyProc(interp, valuePtr);
1404     if (result != TCL_OK) {
1405     TRACE_WITH_OBJ(("%u \"%.30s\" (by %s) => ERROR converting increment amount to int: ",
1406     opnd, O2S(elemPtr), O2S(valuePtr)),
1407     Tcl_GetObjResult(interp));
1408     Tcl_DecrRefCount(elemPtr);
1409     Tcl_DecrRefCount(valuePtr);
1410     goto checkForCatch;
1411     }
1412     }
1413     i = valuePtr->internalRep.longValue;
1414     DECACHE_STACK_INFO();
1415     value2Ptr = TclIncrElementOfIndexedArray(interp, opnd,
1416     elemPtr, i);
1417     CACHE_STACK_INFO();
1418     if (value2Ptr == NULL) {
1419     TRACE_WITH_OBJ(("%u \"%.30s\" (by %ld) => ERROR: ",
1420     opnd, O2S(elemPtr), i),
1421     Tcl_GetObjResult(interp));
1422     Tcl_DecrRefCount(elemPtr);
1423     Tcl_DecrRefCount(valuePtr);
1424     result = TCL_ERROR;
1425     goto checkForCatch;
1426     }
1427     PUSH_OBJECT(value2Ptr);
1428     TRACE_WITH_OBJ(("%u \"%.30s\" (by %ld) => ",
1429     opnd, O2S(elemPtr), i), value2Ptr);
1430     Tcl_DecrRefCount(elemPtr);
1431     Tcl_DecrRefCount(valuePtr);
1432     }
1433     ADJUST_PC(2);
1434    
1435     case INST_INCR_ARRAY_STK:
1436     {
1437     Tcl_Obj *elemPtr;
1438    
1439     valuePtr = POP_OBJECT();
1440     elemPtr = POP_OBJECT();
1441     objPtr = POP_OBJECT(); /* array name */
1442     if (valuePtr->typePtr != &tclIntType) {
1443     result = tclIntType.setFromAnyProc(interp, valuePtr);
1444     if (result != TCL_OK) {
1445     TRACE_WITH_OBJ(("\"%.30s(%.30s)\" (by %s) => ERROR converting increment amount to int: ",
1446     O2S(objPtr), O2S(elemPtr), O2S(valuePtr)),
1447     Tcl_GetObjResult(interp));
1448     Tcl_DecrRefCount(objPtr);
1449     Tcl_DecrRefCount(elemPtr);
1450     Tcl_DecrRefCount(valuePtr);
1451     goto checkForCatch;
1452     }
1453     }
1454     i = valuePtr->internalRep.longValue;
1455     DECACHE_STACK_INFO();
1456     value2Ptr = TclIncrVar2(interp, objPtr, elemPtr, i,
1457     TCL_LEAVE_ERR_MSG);
1458     CACHE_STACK_INFO();
1459     if (value2Ptr == NULL) {
1460     TRACE_WITH_OBJ(("\"%.30s(%.30s)\" (by %ld) => ERROR: ",
1461     O2S(objPtr), O2S(elemPtr), i),
1462     Tcl_GetObjResult(interp));
1463     Tcl_DecrRefCount(objPtr);
1464     Tcl_DecrRefCount(elemPtr);
1465     Tcl_DecrRefCount(valuePtr);
1466     result = TCL_ERROR;
1467     goto checkForCatch;
1468     }
1469     PUSH_OBJECT(value2Ptr);
1470     TRACE_WITH_OBJ(("\"%.30s(%.30s)\" (by %ld) => ",
1471     O2S(objPtr), O2S(elemPtr), i), value2Ptr);
1472     Tcl_DecrRefCount(objPtr);
1473     Tcl_DecrRefCount(elemPtr);
1474     Tcl_DecrRefCount(valuePtr);
1475     }
1476     ADJUST_PC(1);
1477    
1478     case INST_INCR_SCALAR1_IMM:
1479     opnd = TclGetUInt1AtPtr(pc+1);
1480     i = TclGetInt1AtPtr(pc+2);
1481     DECACHE_STACK_INFO();
1482     value2Ptr = TclIncrIndexedScalar(interp, opnd, i);
1483     CACHE_STACK_INFO();
1484     if (value2Ptr == NULL) {
1485     TRACE_WITH_OBJ(("%u %ld => ERROR: ", opnd, i),
1486     Tcl_GetObjResult(interp));
1487     result = TCL_ERROR;
1488     goto checkForCatch;
1489     }
1490     PUSH_OBJECT(value2Ptr);
1491     TRACE_WITH_OBJ(("%u %ld => ", opnd, i), value2Ptr);
1492     ADJUST_PC(3);
1493    
1494     case INST_INCR_SCALAR_STK_IMM:
1495     case INST_INCR_STK_IMM:
1496     objPtr = POP_OBJECT(); /* variable name */
1497     i = TclGetInt1AtPtr(pc+1);
1498     DECACHE_STACK_INFO();
1499     value2Ptr = TclIncrVar2(interp, objPtr, (Tcl_Obj *) NULL, i,
1500     TCL_LEAVE_ERR_MSG);
1501     CACHE_STACK_INFO();
1502     if (value2Ptr == NULL) {
1503     TRACE_WITH_OBJ(("\"%.30s\" %ld => ERROR: ",
1504     O2S(objPtr), i), Tcl_GetObjResult(interp));
1505     result = TCL_ERROR;
1506     Tcl_DecrRefCount(objPtr);
1507     goto checkForCatch;
1508     }
1509     PUSH_OBJECT(value2Ptr);
1510     TRACE_WITH_OBJ(("\"%.30s\" %ld => ", O2S(objPtr), i),
1511     value2Ptr);
1512     TclDecrRefCount(objPtr);
1513     ADJUST_PC(2);
1514    
1515     case INST_INCR_ARRAY1_IMM:
1516     {
1517     Tcl_Obj *elemPtr;
1518    
1519     opnd = TclGetUInt1AtPtr(pc+1);
1520     i = TclGetInt1AtPtr(pc+2);
1521     elemPtr = POP_OBJECT();
1522     DECACHE_STACK_INFO();
1523     value2Ptr = TclIncrElementOfIndexedArray(interp, opnd,
1524     elemPtr, i);
1525     CACHE_STACK_INFO();
1526     if (value2Ptr == NULL) {
1527     TRACE_WITH_OBJ(("%u \"%.30s\" (by %ld) => ERROR: ",
1528     opnd, O2S(elemPtr), i),
1529     Tcl_GetObjResult(interp));
1530     Tcl_DecrRefCount(elemPtr);
1531     result = TCL_ERROR;
1532     goto checkForCatch;
1533     }
1534     PUSH_OBJECT(value2Ptr);
1535     TRACE_WITH_OBJ(("%u \"%.30s\" (by %ld) => ",
1536     opnd, O2S(elemPtr), i), value2Ptr);
1537     Tcl_DecrRefCount(elemPtr);
1538     }
1539     ADJUST_PC(3);
1540    
1541     case INST_INCR_ARRAY_STK_IMM:
1542     {
1543     Tcl_Obj *elemPtr;
1544    
1545     i = TclGetInt1AtPtr(pc+1);
1546     elemPtr = POP_OBJECT();
1547     objPtr = POP_OBJECT(); /* array name */
1548     DECACHE_STACK_INFO();
1549     value2Ptr = TclIncrVar2(interp, objPtr, elemPtr, i,
1550     TCL_LEAVE_ERR_MSG);
1551     CACHE_STACK_INFO();
1552     if (value2Ptr == NULL) {
1553     TRACE_WITH_OBJ(("\"%.30s(%.30s)\" (by %ld) => ERROR: ",
1554     O2S(objPtr), O2S(elemPtr), i),
1555     Tcl_GetObjResult(interp));
1556     Tcl_DecrRefCount(objPtr);
1557     Tcl_DecrRefCount(elemPtr);
1558     result = TCL_ERROR;
1559     goto checkForCatch;
1560     }
1561     PUSH_OBJECT(value2Ptr);
1562     TRACE_WITH_OBJ(("\"%.30s(%.30s)\" (by %ld) => ",
1563     O2S(objPtr), O2S(elemPtr), i), value2Ptr);
1564     Tcl_DecrRefCount(objPtr);
1565     Tcl_DecrRefCount(elemPtr);
1566     }
1567     ADJUST_PC(2);
1568    
1569     case INST_JUMP1:
1570     #ifdef TCL_COMPILE_DEBUG
1571     opnd = TclGetInt1AtPtr(pc+1);
1572     TRACE(("%d => new pc %u\n", opnd,
1573     (unsigned int)(pc + opnd - codePtr->codeStart)));
1574     pc += opnd;
1575     #else
1576     pc += TclGetInt1AtPtr(pc+1);
1577     #endif /* TCL_COMPILE_DEBUG */
1578     continue;
1579    
1580     case INST_JUMP4:
1581     opnd = TclGetInt4AtPtr(pc+1);
1582     TRACE(("%d => new pc %u\n", opnd,
1583     (unsigned int)(pc + opnd - codePtr->codeStart)));
1584     ADJUST_PC(opnd);
1585    
1586     case INST_JUMP_TRUE4:
1587     opnd = TclGetInt4AtPtr(pc+1);
1588     pcAdjustment = 5;
1589     goto doJumpTrue;
1590    
1591     case INST_JUMP_TRUE1:
1592     opnd = TclGetInt1AtPtr(pc+1);
1593     pcAdjustment = 2;
1594    
1595     doJumpTrue:
1596     {
1597     int b;
1598    
1599     valuePtr = POP_OBJECT();
1600     if (valuePtr->typePtr == &tclIntType) {
1601     b = (valuePtr->internalRep.longValue != 0);
1602     } else if (valuePtr->typePtr == &tclDoubleType) {
1603     b = (valuePtr->internalRep.doubleValue != 0.0);
1604     } else {
1605     result = Tcl_GetBooleanFromObj(interp, valuePtr, &b);
1606     if (result != TCL_OK) {
1607     TRACE_WITH_OBJ(("%d => ERROR: ", opnd),
1608     Tcl_GetObjResult(interp));
1609     Tcl_DecrRefCount(valuePtr);
1610     goto checkForCatch;
1611     }
1612     }
1613     if (b) {
1614     TRACE(("%d => %.20s true, new pc %u\n",
1615     opnd, O2S(valuePtr),
1616     (unsigned int)(pc+opnd - codePtr->codeStart)));
1617     TclDecrRefCount(valuePtr);
1618     ADJUST_PC(opnd);
1619     } else {
1620     TRACE(("%d => %.20s false\n", opnd, O2S(valuePtr)));
1621     TclDecrRefCount(valuePtr);
1622     ADJUST_PC(pcAdjustment);
1623     }
1624     }
1625    
1626     case INST_JUMP_FALSE4:
1627     opnd = TclGetInt4AtPtr(pc+1);
1628     pcAdjustment = 5;
1629     goto doJumpFalse;
1630    
1631     case INST_JUMP_FALSE1:
1632     opnd = TclGetInt1AtPtr(pc+1);
1633     pcAdjustment = 2;
1634    
1635     doJumpFalse:
1636     {
1637     int b;
1638    
1639     valuePtr = POP_OBJECT();
1640     if (valuePtr->typePtr == &tclIntType) {
1641     b = (valuePtr->internalRep.longValue != 0);
1642     } else if (valuePtr->typePtr == &tclDoubleType) {
1643     b = (valuePtr->internalRep.doubleValue != 0.0);
1644     } else {
1645     result = Tcl_GetBooleanFromObj(interp, valuePtr, &b);
1646     if (result != TCL_OK) {
1647     TRACE_WITH_OBJ(("%d => ERROR: ", opnd),
1648     Tcl_GetObjResult(interp));
1649     Tcl_DecrRefCount(valuePtr);
1650     goto checkForCatch;
1651     }
1652     }
1653     if (b) {
1654     TRACE(("%d => %.20s true\n", opnd, O2S(valuePtr)));
1655     TclDecrRefCount(valuePtr);
1656     ADJUST_PC(pcAdjustment);
1657     } else {
1658     TRACE(("%d => %.20s false, new pc %u\n",
1659     opnd, O2S(valuePtr),
1660     (unsigned int)(pc + opnd - codePtr->codeStart)));
1661     TclDecrRefCount(valuePtr);
1662     ADJUST_PC(opnd);
1663     }
1664     }
1665    
1666     case INST_LOR:
1667     case INST_LAND:
1668     {
1669     /*
1670     * Operands must be boolean or numeric. No int->double
1671     * conversions are performed.
1672     */
1673    
1674     int i1, i2;
1675     int iResult;
1676     char *s;
1677     Tcl_ObjType *t1Ptr, *t2Ptr;
1678    
1679     value2Ptr = POP_OBJECT();
1680     valuePtr = POP_OBJECT();
1681     t1Ptr = valuePtr->typePtr;
1682     t2Ptr = value2Ptr->typePtr;
1683    
1684     if ((t1Ptr == &tclIntType) || (t1Ptr == &tclBooleanType)) {
1685     i1 = (valuePtr->internalRep.longValue != 0);
1686     } else if (t1Ptr == &tclDoubleType) {
1687     i1 = (valuePtr->internalRep.doubleValue != 0.0);
1688     } else {
1689     s = Tcl_GetStringFromObj(valuePtr, &length);
1690     if (TclLooksLikeInt(s, length)) {
1691     result = Tcl_GetLongFromObj((Tcl_Interp *) NULL,
1692     valuePtr, &i);
1693     i1 = (i != 0);
1694     } else {
1695     result = Tcl_GetBooleanFromObj((Tcl_Interp *) NULL,
1696     valuePtr, &i1);
1697     i1 = (i1 != 0);
1698     }
1699     if (result != TCL_OK) {
1700     TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n",
1701     O2S(valuePtr),
1702     (t1Ptr? t1Ptr->name : "null")));
1703     IllegalExprOperandType(interp, pc, valuePtr);
1704     Tcl_DecrRefCount(valuePtr);
1705     Tcl_DecrRefCount(value2Ptr);
1706     goto checkForCatch;
1707     }
1708     }
1709    
1710     if ((t2Ptr == &tclIntType) || (t2Ptr == &tclBooleanType)) {
1711     i2 = (value2Ptr->internalRep.longValue != 0);
1712     } else if (t2Ptr == &tclDoubleType) {
1713     i2 = (value2Ptr->internalRep.doubleValue != 0.0);
1714     } else {
1715     s = Tcl_GetStringFromObj(value2Ptr, &length);
1716     if (TclLooksLikeInt(s, length)) {
1717     result = Tcl_GetLongFromObj((Tcl_Interp *) NULL,
1718     value2Ptr, &i);
1719     i2 = (i != 0);
1720     } else {
1721     result = Tcl_GetBooleanFromObj((Tcl_Interp *) NULL,
1722     value2Ptr, &i2);
1723     }
1724     if (result != TCL_OK) {
1725     TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n",
1726     O2S(value2Ptr),
1727     (t2Ptr? t2Ptr->name : "null")));
1728     IllegalExprOperandType(interp, pc, value2Ptr);
1729     Tcl_DecrRefCount(valuePtr);
1730     Tcl_DecrRefCount(value2Ptr);
1731     goto checkForCatch;
1732     }
1733     }
1734    
1735     /*
1736     * Reuse the valuePtr object already on stack if possible.
1737     */
1738    
1739     if (*pc == INST_LOR) {
1740     iResult = (i1 || i2);
1741     } else {
1742     iResult = (i1 && i2);
1743     }
1744     if (Tcl_IsShared(valuePtr)) {
1745     PUSH_OBJECT(Tcl_NewLongObj(iResult));
1746     TRACE(("%.20s %.20s => %d\n",
1747     O2S(valuePtr), O2S(value2Ptr), iResult));
1748     TclDecrRefCount(valuePtr);
1749     } else { /* reuse the valuePtr object */
1750     TRACE(("%.20s %.20s => %d\n",
1751     O2S(valuePtr), O2S(value2Ptr), iResult));
1752     Tcl_SetLongObj(valuePtr, iResult);
1753     ++stackTop; /* valuePtr now on stk top has right r.c. */
1754     }
1755     TclDecrRefCount(value2Ptr);
1756     }
1757     ADJUST_PC(1);
1758    
1759     case INST_EQ:
1760     case INST_NEQ:
1761     case INST_LT:
1762     case INST_GT:
1763     case INST_LE:
1764     case INST_GE:
1765     {
1766     /*
1767     * Any type is allowed but the two operands must have the
1768     * same type. We will compute value op value2.
1769     */
1770    
1771     Tcl_ObjType *t1Ptr, *t2Ptr;
1772     char *s1 = NULL; /* Init. avoids compiler warning. */
1773     char *s2 = NULL; /* Init. avoids compiler warning. */
1774     long i2 = 0; /* Init. avoids compiler warning. */
1775     double d1 = 0.0; /* Init. avoids compiler warning. */
1776     double d2 = 0.0; /* Init. avoids compiler warning. */
1777     long iResult = 0; /* Init. avoids compiler warning. */
1778    
1779     value2Ptr = POP_OBJECT();
1780     valuePtr = POP_OBJECT();
1781     t1Ptr = valuePtr->typePtr;
1782     t2Ptr = value2Ptr->typePtr;
1783    
1784     /*
1785     * We only want to coerce numeric validation if
1786     * neither type is NULL. A NULL type means the arg is
1787     * essentially an empty object ("", {} or [list]).
1788     */
1789     if (!((((t1Ptr == NULL) && (valuePtr->bytes == NULL))
1790     || (valuePtr->bytes && (valuePtr->length == 0)))
1791     || (((t2Ptr == NULL) && (value2Ptr->bytes == NULL))
1792     || (value2Ptr->bytes && (value2Ptr->length == 0))))) {
1793     if ((t1Ptr != &tclIntType) && (t1Ptr != &tclDoubleType)) {
1794     s1 = Tcl_GetStringFromObj(valuePtr, &length);
1795     if (TclLooksLikeInt(s1, length)) {
1796     (void) Tcl_GetLongFromObj((Tcl_Interp *) NULL,
1797     valuePtr, &i);
1798     } else {
1799     (void) Tcl_GetDoubleFromObj((Tcl_Interp *) NULL,
1800     valuePtr, &d1);
1801     }
1802     t1Ptr = valuePtr->typePtr;
1803     }
1804     if ((t2Ptr != &tclIntType) && (t2Ptr != &tclDoubleType)) {
1805     s2 = Tcl_GetStringFromObj(value2Ptr, &length);
1806     if (TclLooksLikeInt(s2, length)) {
1807     (void) Tcl_GetLongFromObj((Tcl_Interp *) NULL,
1808     value2Ptr, &i2);
1809     } else {
1810     (void) Tcl_GetDoubleFromObj((Tcl_Interp *) NULL,
1811     value2Ptr, &d2);
1812     }
1813     t2Ptr = value2Ptr->typePtr;
1814     }
1815     }
1816     if (((t1Ptr != &tclIntType) && (t1Ptr != &tclDoubleType))
1817     || ((t2Ptr != &tclIntType) && (t2Ptr != &tclDoubleType))) {
1818     /*
1819     * One operand is not numeric. Compare as strings.
1820     */
1821     int cmpValue;
1822     s1 = Tcl_GetString(valuePtr);
1823     s2 = Tcl_GetString(value2Ptr);
1824     cmpValue = strcmp(s1, s2);
1825     switch (*pc) {
1826     case INST_EQ:
1827     iResult = (cmpValue == 0);
1828     break;
1829     case INST_NEQ:
1830     iResult = (cmpValue != 0);
1831     break;
1832     case INST_LT:
1833     iResult = (cmpValue < 0);
1834     break;
1835     case INST_GT:
1836     iResult = (cmpValue > 0);
1837     break;
1838     case INST_LE:
1839     iResult = (cmpValue <= 0);
1840     break;
1841     case INST_GE:
1842     iResult = (cmpValue >= 0);
1843     break;
1844     }
1845     } else if ((t1Ptr == &tclDoubleType)
1846     || (t2Ptr == &tclDoubleType)) {
1847     /*
1848     * Compare as doubles.
1849     */
1850     if (t1Ptr == &tclDoubleType) {
1851     d1 = valuePtr->internalRep.doubleValue;
1852     if (t2Ptr == &tclIntType) {
1853     d2 = value2Ptr->internalRep.longValue;
1854     } else {
1855     d2 = value2Ptr->internalRep.doubleValue;
1856     }
1857     } else { /* t1Ptr is int, t2Ptr is double */
1858     d1 = valuePtr->internalRep.longValue;
1859     d2 = value2Ptr->internalRep.doubleValue;
1860     }
1861     switch (*pc) {
1862     case INST_EQ:
1863     iResult = d1 == d2;
1864     break;
1865     case INST_NEQ:
1866     iResult = d1 != d2;
1867     break;
1868     case INST_LT:
1869     iResult = d1 < d2;
1870     break;
1871     case INST_GT:
1872     iResult = d1 > d2;
1873     break;
1874     case INST_LE:
1875     iResult = d1 <= d2;
1876     break;
1877     case INST_GE:
1878     iResult = d1 >= d2;
1879     break;
1880     }
1881     } else {
1882     /*
1883     * Compare as ints.
1884     */
1885     i = valuePtr->internalRep.longValue;
1886     i2 = value2Ptr->internalRep.longValue;
1887     switch (*pc) {
1888     case INST_EQ:
1889     iResult = i == i2;
1890     break;
1891     case INST_NEQ:
1892     iResult = i != i2;
1893     break;
1894     case INST_LT:
1895     iResult = i < i2;
1896     break;
1897     case INST_GT:
1898     iResult = i > i2;
1899     break;
1900     case INST_LE:
1901     iResult = i <= i2;
1902     break;
1903     case INST_GE:
1904     iResult = i >= i2;
1905     break;
1906     }
1907     }
1908    
1909     /*
1910     * Reuse the valuePtr object already on stack if possible.
1911     */
1912    
1913     if (Tcl_IsShared(valuePtr)) {
1914     PUSH_OBJECT(Tcl_NewLongObj(iResult));
1915     TRACE(("%.20s %.20s => %ld\n",
1916     O2S(valuePtr), O2S(value2Ptr), iResult));
1917     TclDecrRefCount(valuePtr);
1918     } else { /* reuse the valuePtr object */
1919     TRACE(("%.20s %.20s => %ld\n",
1920     O2S(valuePtr), O2S(value2Ptr), iResult));
1921     Tcl_SetLongObj(valuePtr, iResult);
1922     ++stackTop; /* valuePtr now on stk top has right r.c. */
1923     }
1924     TclDecrRefCount(value2Ptr);
1925     }
1926     ADJUST_PC(1);
1927    
1928     case INST_MOD:
1929     case INST_LSHIFT:
1930     case INST_RSHIFT:
1931     case INST_BITOR:
1932     case INST_BITXOR:
1933     case INST_BITAND:
1934     {
1935     /*
1936     * Only integers are allowed. We compute value op value2.
1937     */
1938    
1939     long i2, rem, negative;
1940     long iResult = 0; /* Init. avoids compiler warning. */
1941    
1942     value2Ptr = POP_OBJECT();
1943     valuePtr = POP_OBJECT();
1944     if (valuePtr->typePtr == &tclIntType) {
1945     i = valuePtr->internalRep.longValue;
1946     } else { /* try to convert to int */
1947     result = Tcl_GetLongFromObj((Tcl_Interp *) NULL,
1948     valuePtr, &i);
1949     if (result != TCL_OK) {
1950     TRACE(("%.20s %.20s => ILLEGAL 1st TYPE %s\n",
1951     O2S(valuePtr), O2S(value2Ptr),
1952     (valuePtr->typePtr?
1953     valuePtr->typePtr->name : "null")));
1954     IllegalExprOperandType(interp, pc, valuePtr);
1955     Tcl_DecrRefCount(valuePtr);
1956     Tcl_DecrRefCount(value2Ptr);
1957     goto checkForCatch;
1958     }
1959     }
1960     if (value2Ptr->typePtr == &tclIntType) {
1961     i2 = value2Ptr->internalRep.longValue;
1962     } else {
1963     result = Tcl_GetLongFromObj((Tcl_Interp *) NULL,
1964     value2Ptr, &i2);
1965     if (result != TCL_OK) {
1966     TRACE(("%.20s %.20s => ILLEGAL 2nd TYPE %s\n",
1967     O2S(valuePtr), O2S(value2Ptr),
1968     (value2Ptr->typePtr?
1969     value2Ptr->typePtr->name : "null")));
1970     IllegalExprOperandType(interp, pc, value2Ptr);
1971     Tcl_DecrRefCount(valuePtr);
1972     Tcl_DecrRefCount(value2Ptr);
1973     goto checkForCatch;
1974     }
1975     }
1976    
1977     switch (*pc) {
1978     case INST_MOD:
1979     /*
1980     * This code is tricky: C doesn't guarantee much about
1981     * the quotient or remainder, but Tcl does. The
1982     * remainder always has the same sign as the divisor and
1983     * a smaller absolute value.
1984     */
1985     if (i2 == 0) {
1986     TRACE(("%ld %ld => DIVIDE BY ZERO\n", i, i2));
1987     Tcl_DecrRefCount(valuePtr);
1988     Tcl_DecrRefCount(value2Ptr);
1989     goto divideByZero;
1990     }
1991     negative = 0;
1992     if (i2 < 0) {
1993     i2 = -i2;
1994     i = -i;
1995     negative = 1;
1996     }
1997     rem = i % i2;
1998     if (rem < 0) {
1999     rem += i2;
2000     }
2001     if (negative) {
2002     rem = -rem;
2003     }
2004     iResult = rem;
2005     break;
2006     case INST_LSHIFT:
2007     iResult = i << i2;
2008     break;
2009     case INST_RSHIFT:
2010     /*
2011     * The following code is a bit tricky: it ensures that
2012     * right shifts propagate the sign bit even on machines
2013     * where ">>" won't do it by default.
2014     */
2015     if (i < 0) {
2016     iResult = ~((~i) >> i2);
2017     } else {
2018     iResult = i >> i2;
2019     }
2020     break;
2021     case INST_BITOR:
2022     iResult = i | i2;
2023     break;
2024     case INST_BITXOR:
2025     iResult = i ^ i2;
2026     break;
2027     case INST_BITAND:
2028     iResult = i & i2;
2029     break;
2030     }
2031    
2032     /*
2033     * Reuse the valuePtr object already on stack if possible.
2034     */
2035    
2036     if (Tcl_IsShared(valuePtr)) {
2037     PUSH_OBJECT(Tcl_NewLongObj(iResult));
2038     TRACE(("%ld %ld => %ld\n", i, i2, iResult));
2039     TclDecrRefCount(valuePtr);
2040     } else { /* reuse the valuePtr object */
2041     TRACE(("%ld %ld => %ld\n", i, i2, iResult));
2042     Tcl_SetLongObj(valuePtr, iResult);
2043     ++stackTop; /* valuePtr now on stk top has right r.c. */
2044     }
2045     TclDecrRefCount(value2Ptr);
2046     }
2047     ADJUST_PC(1);
2048    
2049     case INST_ADD:
2050     case INST_SUB:
2051     case INST_MULT:
2052     case INST_DIV:
2053     {
2054     /*
2055     * Operands must be numeric and ints get converted to floats
2056     * if necessary. We compute value op value2.
2057     */
2058    
2059     Tcl_ObjType *t1Ptr, *t2Ptr;
2060     long i2, quot, rem;
2061     double d1, d2;
2062     long iResult = 0; /* Init. avoids compiler warning. */
2063     double dResult = 0.0; /* Init. avoids compiler warning. */
2064     int doDouble = 0; /* 1 if doing floating arithmetic */
2065    
2066     value2Ptr = POP_OBJECT();
2067     valuePtr = POP_OBJECT();
2068     t1Ptr = valuePtr->typePtr;
2069     t2Ptr = value2Ptr->typePtr;
2070    
2071     if (t1Ptr == &tclIntType) {
2072     i = valuePtr->internalRep.longValue;
2073     } else if ((t1Ptr == &tclDoubleType)
2074     && (valuePtr->bytes == NULL)) {
2075     /*
2076     * We can only use the internal rep directly if there is
2077     * no string rep. Otherwise the string rep might actually
2078     * look like an integer, which is preferred.
2079     */
2080    
2081     d1 = valuePtr->internalRep.doubleValue;
2082     } else {
2083     char *s = Tcl_GetStringFromObj(valuePtr, &length);
2084     if (TclLooksLikeInt(s, length)) {
2085     result = Tcl_GetLongFromObj((Tcl_Interp *) NULL,
2086     valuePtr, &i);
2087     } else {
2088     result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL,
2089     valuePtr, &d1);
2090     }
2091     if (result != TCL_OK) {
2092     TRACE(("%.20s %.20s => ILLEGAL 1st TYPE %s\n",
2093     s, O2S(valuePtr),
2094     (valuePtr->typePtr?
2095     valuePtr->typePtr->name : "null")));
2096     IllegalExprOperandType(interp, pc, valuePtr);
2097     Tcl_DecrRefCount(valuePtr);
2098     Tcl_DecrRefCount(value2Ptr);
2099     goto checkForCatch;
2100     }
2101     t1Ptr = valuePtr->typePtr;
2102     }
2103    
2104     if (t2Ptr == &tclIntType) {
2105     i2 = value2Ptr->internalRep.longValue;
2106     } else if ((t2Ptr == &tclDoubleType)
2107     && (value2Ptr->bytes == NULL)) {
2108     /*
2109     * We can only use the internal rep directly if there is
2110     * no string rep. Otherwise the string rep might actually
2111     * look like an integer, which is preferred.
2112     */
2113    
2114     d2 = value2Ptr->internalRep.doubleValue;
2115     } else {
2116     char *s = Tcl_GetStringFromObj(value2Ptr, &length);
2117     if (TclLooksLikeInt(s, length)) {
2118     result = Tcl_GetLongFromObj((Tcl_Interp *) NULL,
2119     value2Ptr, &i2);
2120     } else {
2121     result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL,
2122     value2Ptr, &d2);
2123     }
2124     if (result != TCL_OK) {
2125     TRACE(("%.20s %.20s => ILLEGAL 2nd TYPE %s\n",
2126     O2S(value2Ptr), s,
2127     (value2Ptr->typePtr?
2128     value2Ptr->typePtr->name : "null")));
2129     IllegalExprOperandType(interp, pc, value2Ptr);
2130     Tcl_DecrRefCount(valuePtr);
2131     Tcl_DecrRefCount(value2Ptr);
2132     goto checkForCatch;
2133     }
2134     t2Ptr = value2Ptr->typePtr;
2135     }
2136    
2137     if ((t1Ptr == &tclDoubleType) || (t2Ptr == &tclDoubleType)) {
2138     /*
2139     * Do double arithmetic.
2140     */
2141     doDouble = 1;
2142     if (t1Ptr == &tclIntType) {
2143     d1 = i; /* promote value 1 to double */
2144     } else if (t2Ptr == &tclIntType) {
2145     d2 = i2; /* promote value 2 to double */
2146     }
2147     switch (*pc) {
2148     case INST_ADD:
2149     dResult = d1 + d2;
2150     break;
2151     case INST_SUB:
2152     dResult = d1 - d2;
2153     break;
2154     case INST_MULT:
2155     dResult = d1 * d2;
2156     break;
2157     case INST_DIV:
2158     if (d2 == 0.0) {
2159     TRACE(("%.6g %.6g => DIVIDE BY ZERO\n", d1, d2));
2160     Tcl_DecrRefCount(valuePtr);
2161     Tcl_DecrRefCount(value2Ptr);
2162     goto divideByZero;
2163     }
2164     dResult = d1 / d2;
2165     break;
2166     }
2167    
2168     /*
2169     * Check now for IEEE floating-point error.
2170     */
2171    
2172     if (IS_NAN(dResult) || IS_INF(dResult)) {
2173     TRACE(("%.20s %.20s => IEEE FLOATING PT ERROR\n",
2174     O2S(valuePtr), O2S(value2Ptr)));
2175     TclExprFloatError(interp, dResult);
2176     result = TCL_ERROR;
2177     Tcl_DecrRefCount(valuePtr);
2178     Tcl_DecrRefCount(value2Ptr);
2179     goto checkForCatch;
2180     }
2181     } else {
2182     /*
2183     * Do integer arithmetic.
2184     */
2185     switch (*pc) {
2186     case INST_ADD:
2187     iResult = i + i2;
2188     break;
2189     case INST_SUB:
2190     iResult = i - i2;
2191     break;
2192     case INST_MULT:
2193     iResult = i * i2;
2194     break;
2195     case INST_DIV:
2196     /*
2197     * This code is tricky: C doesn't guarantee much
2198     * about the quotient or remainder, but Tcl does.
2199     * The remainder always has the same sign as the
2200     * divisor and a smaller absolute value.
2201     */
2202     if (i2 == 0) {
2203     TRACE(("%ld %ld => DIVIDE BY ZERO\n", i, i2));
2204     Tcl_DecrRefCount(valuePtr);
2205     Tcl_DecrRefCount(value2Ptr);
2206     goto divideByZero;
2207     }
2208     if (i2 < 0) {
2209     i2 = -i2;
2210     i = -i;
2211     }
2212     quot = i / i2;
2213     rem = i % i2;
2214     if (rem < 0) {
2215     quot -= 1;
2216     }
2217     iResult = quot;
2218     break;
2219     }
2220     }
2221    
2222     /*
2223     * Reuse the valuePtr object already on stack if possible.
2224     */
2225    
2226     if (Tcl_IsShared(valuePtr)) {
2227     if (doDouble) {
2228     PUSH_OBJECT(Tcl_NewDoubleObj(dResult));
2229     TRACE(("%.6g %.6g => %.6g\n", d1, d2, dResult));
2230     } else {
2231     PUSH_OBJECT(Tcl_NewLongObj(iResult));
2232     TRACE(("%ld %ld => %ld\n", i, i2, iResult));
2233     }
2234     TclDecrRefCount(valuePtr);
2235     } else { /* reuse the valuePtr object */
2236     if (doDouble) { /* NB: stack top is off by 1 */
2237     TRACE(("%.6g %.6g => %.6g\n", d1, d2, dResult));
2238     Tcl_SetDoubleObj(valuePtr, dResult);
2239     } else {
2240     TRACE(("%ld %ld => %ld\n", i, i2, iResult));
2241     Tcl_SetLongObj(valuePtr, iResult);
2242     }
2243     ++stackTop; /* valuePtr now on stk top has right r.c. */
2244     }
2245     TclDecrRefCount(value2Ptr);
2246     }
2247     ADJUST_PC(1);
2248    
2249     case INST_UPLUS:
2250     {
2251     /*
2252     * Operand must be numeric.
2253     */
2254    
2255     double d;
2256     Tcl_ObjType *tPtr;
2257    
2258     valuePtr = stackPtr[stackTop];
2259     tPtr = valuePtr->typePtr;
2260     if ((tPtr != &tclIntType) && ((tPtr != &tclDoubleType)
2261     || (valuePtr->bytes != NULL))) {
2262     char *s = Tcl_GetStringFromObj(valuePtr, &length);
2263     if (TclLooksLikeInt(s, length)) {
2264     result = Tcl_GetLongFromObj((Tcl_Interp *) NULL,
2265     valuePtr, &i);
2266     } else {
2267     result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL,
2268     valuePtr, &d);
2269     }
2270     if (result != TCL_OK) {
2271     TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n",
2272     s, (tPtr? tPtr->name : "null")));
2273     IllegalExprOperandType(interp, pc, valuePtr);
2274     goto checkForCatch;
2275     }
2276     tPtr = valuePtr->typePtr;
2277     }
2278    
2279     /*
2280     * Ensure that the operand's string rep is the same as the
2281     * formatted version of its internal rep. This makes sure
2282     * that "expr +000123" yields "83", not "000123". We
2283     * implement this by _discarding_ the string rep since we
2284     * know it will be regenerated, if needed later, by
2285     * formatting the internal rep's value.
2286     */
2287    
2288     if (Tcl_IsShared(valuePtr)) {
2289     if (tPtr == &tclIntType) {
2290     i = valuePtr->internalRep.longValue;
2291     objPtr = Tcl_NewLongObj(i);
2292     } else {
2293     d = valuePtr->internalRep.doubleValue;
2294     objPtr = Tcl_NewDoubleObj(d);
2295     }
2296     Tcl_IncrRefCount(objPtr);
2297     Tcl_DecrRefCount(valuePtr);
2298     valuePtr = objPtr;
2299     stackPtr[stackTop] = valuePtr;
2300     } else {
2301     Tcl_InvalidateStringRep(valuePtr);
2302     }
2303     TRACE_WITH_OBJ(("%s => ", O2S(valuePtr)), valuePtr);
2304     }
2305     ADJUST_PC(1);
2306    
2307     case INST_UMINUS:
2308     case INST_LNOT:
2309     {
2310     /*
2311     * The operand must be numeric. If the operand object is
2312     * unshared modify it directly, otherwise create a copy to
2313     * modify: this is "copy on write". free any old string
2314     * representation since it is now invalid.
2315     */
2316    
2317     double d;
2318     Tcl_ObjType *tPtr;
2319    
2320     valuePtr = POP_OBJECT();
2321     tPtr = valuePtr->typePtr;
2322     if ((tPtr != &tclIntType) && ((tPtr != &tclDoubleType)
2323     || (valuePtr->bytes != NULL))) {
2324     if ((tPtr == &tclBooleanType)
2325     && (valuePtr->bytes == NULL)) {
2326     valuePtr->typePtr = &tclIntType;
2327     } else {
2328     char *s = Tcl_GetStringFromObj(valuePtr, &length);
2329     if (TclLooksLikeInt(s, length)) {
2330     result = Tcl_GetLongFromObj((Tcl_Interp *) NULL,
2331     valuePtr, &i);
2332     } else {
2333     result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL,
2334     valuePtr, &d);
2335     }
2336     if (result != TCL_OK) {
2337     TRACE(("\"%.20s\" => ILLEGAL TYPE %s\n",
2338     s, (tPtr? tPtr->name : "null")));
2339     IllegalExprOperandType(interp, pc, valuePtr);
2340     Tcl_DecrRefCount(valuePtr);
2341     goto checkForCatch;
2342     }
2343     }
2344     tPtr = valuePtr->typePtr;
2345     }
2346    
2347     if (Tcl_IsShared(valuePtr)) {
2348     /*
2349     * Create a new object.
2350     */
2351     if (tPtr == &tclIntType) {
2352     i = valuePtr->internalRep.longValue;
2353     objPtr = Tcl_NewLongObj(
2354     (*pc == INST_UMINUS)? -i : !i);
2355     TRACE_WITH_OBJ(("%ld => ", i), objPtr);
2356     } else {
2357     d = valuePtr->internalRep.doubleValue;
2358     if (*pc == INST_UMINUS) {
2359     objPtr = Tcl_NewDoubleObj(-d);
2360     } else {
2361     /*
2362     * Should be able to use "!d", but apparently
2363     * some compilers can't handle it.
2364     */
2365     objPtr = Tcl_NewLongObj((d==0.0)? 1 : 0);
2366     }
2367     TRACE_WITH_OBJ(("%.6g => ", d), objPtr);
2368     }
2369     PUSH_OBJECT(objPtr);
2370     TclDecrRefCount(valuePtr);
2371     } else {
2372     /*
2373     * valuePtr is unshared. Modify it directly.
2374     */
2375     if (tPtr == &tclIntType) {
2376     i = valuePtr->internalRep.longValue;
2377     Tcl_SetLongObj(valuePtr,
2378     (*pc == INST_UMINUS)? -i : !i);
2379     TRACE_WITH_OBJ(("%ld => ", i), valuePtr);
2380     } else {
2381     d = valuePtr->internalRep.doubleValue;
2382     if (*pc == INST_UMINUS) {
2383     Tcl_SetDoubleObj(valuePtr, -d);
2384     } else {
2385     /*
2386     * Should be able to use "!d", but apparently
2387     * some compilers can't handle it.
2388     */
2389     Tcl_SetLongObj(valuePtr, (d==0.0)? 1 : 0);
2390     }
2391     TRACE_WITH_OBJ(("%.6g => ", d), valuePtr);
2392     }
2393     ++stackTop; /* valuePtr now on stk top has right r.c. */
2394     }
2395     }
2396     ADJUST_PC(1);
2397    
2398     case INST_BITNOT:
2399     {
2400     /*
2401     * The operand must be an integer. If the operand object is
2402     * unshared modify it directly, otherwise modify a copy.
2403     * Free any old string representation since it is now
2404     * invalid.
2405     */
2406    
2407     Tcl_ObjType *tPtr;
2408    
2409     valuePtr = POP_OBJECT();
2410     tPtr = valuePtr->typePtr;
2411     if (tPtr != &tclIntType) {
2412     result = Tcl_GetLongFromObj((Tcl_Interp *) NULL,
2413     valuePtr, &i);
2414     if (result != TCL_OK) { /* try to convert to double */
2415     TRACE(("\"%.20s\" => ILLEGAL TYPE %s\n",
2416     O2S(valuePtr), (tPtr? tPtr->name : "null")));
2417     IllegalExprOperandType(interp, pc, valuePtr);
2418     Tcl_DecrRefCount(valuePtr);
2419     goto checkForCatch;
2420     }
2421     }
2422    
2423     i = valuePtr->internalRep.longValue;
2424     if (Tcl_IsShared(valuePtr)) {
2425     PUSH_OBJECT(Tcl_NewLongObj(~i));
2426     TRACE(("0x%lx => (%lu)\n", i, ~i));
2427     TclDecrRefCount(valuePtr);
2428     } else {
2429     /*
2430     * valuePtr is unshared. Modify it directly.
2431     */
2432     Tcl_SetLongObj(valuePtr, ~i);
2433     ++stackTop; /* valuePtr now on stk top has right r.c. */
2434     TRACE(("0x%lx => (%lu)\n", i, ~i));
2435     }
2436     }
2437     ADJUST_PC(1);
2438    
2439     case INST_CALL_BUILTIN_FUNC1:
2440     opnd = TclGetUInt1AtPtr(pc+1);
2441     {
2442     /*
2443     * Call one of the built-in Tcl math functions.
2444     */
2445    
2446     BuiltinFunc *mathFuncPtr;
2447     ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
2448    
2449     if ((opnd < 0) || (opnd > LAST_BUILTIN_FUNC)) {
2450     TRACE(("UNRECOGNIZED BUILTIN FUNC CODE %d\n", opnd));
2451     panic("TclExecuteByteCode: unrecognized builtin function code %d", opnd);
2452     }
2453     mathFuncPtr = &(builtinFuncTable[opnd]);
2454     DECACHE_STACK_INFO();
2455     tsdPtr->mathInProgress++;
2456     result = (*mathFuncPtr->proc)(interp, eePtr,
2457     mathFuncPtr->clientData);
2458     tsdPtr->mathInProgress--;
2459     CACHE_STACK_INFO();
2460     if (result != TCL_OK) {
2461     goto checkForCatch;
2462     }
2463     TRACE_WITH_OBJ(("%d => ", opnd), stackPtr[stackTop]);
2464     }
2465     ADJUST_PC(2);
2466    
2467     case INST_CALL_FUNC1:
2468     opnd = TclGetUInt1AtPtr(pc+1);
2469     {
2470     /*
2471     * Call a non-builtin Tcl math function previously
2472     * registered by a call to Tcl_CreateMathFunc.
2473     */
2474    
2475     int objc = opnd; /* Number of arguments. The function name
2476     * is the 0-th argument. */
2477     Tcl_Obj **objv; /* The array of arguments. The function
2478     * name is objv[0]. */
2479     ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
2480    
2481     objv = &(stackPtr[stackTop - (objc-1)]); /* "objv[0]" */
2482     DECACHE_STACK_INFO();
2483     tsdPtr->mathInProgress++;
2484     result = ExprCallMathFunc(interp, eePtr, objc, objv);
2485     tsdPtr->mathInProgress--;
2486     CACHE_STACK_INFO();
2487     if (result != TCL_OK) {
2488     goto checkForCatch;
2489     }
2490     TRACE_WITH_OBJ(("%d => ", objc), stackPtr[stackTop]);
2491     ADJUST_PC(2);
2492     }
2493    
2494     case INST_TRY_CVT_TO_NUMERIC:
2495     {
2496     /*
2497     * Try to convert the topmost stack object to an int or
2498     * double object. This is done in order to support Tcl's
2499     * policy of interpreting operands if at all possible as
2500     * first integers, else floating-point numbers.
2501     */
2502    
2503     double d;
2504     char *s;
2505     Tcl_ObjType *tPtr;
2506     int converted, shared;
2507    
2508     valuePtr = stackPtr[stackTop];
2509     tPtr = valuePtr->typePtr;
2510     converted = 0;
2511     if ((tPtr != &tclIntType) && ((tPtr != &tclDoubleType)
2512     || (valuePtr->bytes != NULL))) {
2513     if ((tPtr == &tclBooleanType)
2514     && (valuePtr->bytes == NULL)) {
2515     valuePtr->typePtr = &tclIntType;
2516     converted = 1;
2517     } else {
2518     s = Tcl_GetStringFromObj(valuePtr, &length);
2519     if (TclLooksLikeInt(s, length)) {
2520     result = Tcl_GetLongFromObj((Tcl_Interp *) NULL,
2521     valuePtr, &i);
2522     } else {
2523     result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL,
2524     valuePtr, &d);
2525     }
2526     if (result == TCL_OK) {
2527     converted = 1;
2528     }
2529     result = TCL_OK; /* reset the result variable */
2530     }
2531     tPtr = valuePtr->typePtr;
2532     }
2533    
2534     /*
2535     * Ensure that the topmost stack object, if numeric, has a
2536     * string rep the same as the formatted version of its
2537     * internal rep. This is used, e.g., to make sure that "expr
2538     * {0001}" yields "1", not "0001". We implement this by
2539     * _discarding_ the string rep since we know it will be
2540     * regenerated, if needed later, by formatting the internal
2541     * rep's value. Also check if there has been an IEEE
2542     * floating point error.
2543     */
2544    
2545     if ((tPtr == &tclIntType) || (tPtr == &tclDoubleType)) {
2546     shared = 0;
2547     if (Tcl_IsShared(valuePtr)) {
2548     shared = 1;
2549     if (valuePtr->bytes != NULL) {
2550     /*
2551     * We only need to make a copy of the object
2552     * when it already had a string rep
2553     */
2554     if (tPtr == &tclIntType) {
2555     i = valuePtr->internalRep.longValue;
2556     objPtr = Tcl_NewLongObj(i);
2557     } else {
2558     d = valuePtr->internalRep.doubleValue;
2559     objPtr = Tcl_NewDoubleObj(d);
2560     }
2561     Tcl_IncrRefCount(objPtr);
2562     TclDecrRefCount(valuePtr);
2563     valuePtr = objPtr;
2564     stackPtr[stackTop] = valuePtr;
2565     tPtr = valuePtr->typePtr;
2566     }
2567     } else {
2568     Tcl_InvalidateStringRep(valuePtr);
2569     }
2570    
2571     if (tPtr == &tclDoubleType) {
2572     d = valuePtr->internalRep.doubleValue;
2573     if (IS_NAN(d) || IS_INF(d)) {
2574     TRACE(("\"%.20s\" => IEEE FLOATING PT ERROR\n",
2575     O2S(valuePtr)));
2576     TclExprFloatError(interp, d);
2577     result = TCL_ERROR;
2578     goto checkForCatch;
2579     }
2580     }
2581     shared = shared; /* lint, shared not used. */
2582     converted = converted; /* lint, converted not used. */
2583     TRACE(("\"%.20s\" => numeric, %s, %s\n", O2S(valuePtr),
2584     (converted? "converted" : "not converted"),
2585     (shared? "shared" : "not shared")));
2586     } else {
2587     TRACE(("\"%.20s\" => not numeric\n", O2S(valuePtr)));
2588     }
2589     }
2590     ADJUST_PC(1);
2591    
2592     case INST_BREAK:
2593     /*
2594     * First reset the interpreter's result. Then find the closest
2595     * enclosing loop or catch exception range, if any. If a loop is
2596     * found, terminate its execution. If the closest is a catch
2597     * exception range, jump to its catchOffset. If no enclosing
2598     * range is found, stop execution and return TCL_BREAK.
2599     */
2600    
2601     Tcl_ResetResult(interp);
2602     rangePtr = GetExceptRangeForPc(pc, /*catchOnly*/ 0, codePtr);
2603     if (rangePtr == NULL) {
2604     TRACE(("=> no encl. loop or catch, returning TCL_BREAK\n"));
2605     result = TCL_BREAK;
2606     goto abnormalReturn; /* no catch exists to check */
2607     }
2608     switch (rangePtr->type) {
2609     case LOOP_EXCEPTION_RANGE:
2610     result = TCL_OK;
2611     TRACE(("=> range at %d, new pc %d\n",
2612     rangePtr->codeOffset, rangePtr->breakOffset));
2613     break;
2614     case CATCH_EXCEPTION_RANGE:
2615     result = TCL_BREAK;
2616     TRACE(("=> ...\n"));
2617     goto processCatch; /* it will use rangePtr */
2618     default:
2619     panic("TclExecuteByteCode: unrecognized ExceptionRange type %d\n", rangePtr->type);
2620     }
2621     pc = (codePtr->codeStart + rangePtr->breakOffset);
2622     continue; /* restart outer instruction loop at pc */
2623    
2624     case INST_CONTINUE:
2625     /*
2626     * Find the closest enclosing loop or catch exception range,
2627     * if any. If a loop is found, skip to its next iteration.
2628     * If the closest is a catch exception range, jump to its
2629     * catchOffset. If no enclosing range is found, stop
2630     * execution and return TCL_CONTINUE.
2631     */
2632    
2633     Tcl_ResetResult(interp);
2634     rangePtr = GetExceptRangeForPc(pc, /*catchOnly*/ 0, codePtr);
2635     if (rangePtr == NULL) {
2636     TRACE(("=> no encl. loop or catch, returning TCL_CONTINUE\n"));
2637     result = TCL_CONTINUE;
2638     goto abnormalReturn;
2639     }
2640     switch (rangePtr->type) {
2641     case LOOP_EXCEPTION_RANGE:
2642     if (rangePtr->continueOffset == -1) {
2643     TRACE(("=> loop w/o continue, checking for catch\n"));
2644     goto checkForCatch;
2645     } else {
2646     result = TCL_OK;
2647     TRACE(("=> range at %d, new pc %d\n",
2648     rangePtr->codeOffset, rangePtr->continueOffset));
2649     }
2650     break;
2651     case CATCH_EXCEPTION_RANGE:
2652     result = TCL_CONTINUE;
2653     TRACE(("=> ...\n"));
2654     goto processCatch; /* it will use rangePtr */
2655     default:
2656     panic("TclExecuteByteCode: unrecognized ExceptionRange type %d\n", rangePtr->type);
2657     }
2658     pc = (codePtr->codeStart + rangePtr->continueOffset);
2659     continue; /* restart outer instruction loop at pc */
2660    
2661     case INST_FOREACH_START4:
2662     opnd = TclGetUInt4AtPtr(pc+1);
2663     {
2664     /*
2665     * Initialize the temporary local var that holds the count
2666     * of the number of iterations of the loop body to -1.
2667     */
2668    
2669     ForeachInfo *infoPtr = (ForeachInfo *)
2670     codePtr->auxDataArrayPtr[opnd].clientData;
2671     int iterTmpIndex = infoPtr->loopCtTemp;
2672     Var *compiledLocals = iPtr->varFramePtr->compiledLocals;
2673     Var *iterVarPtr = &(compiledLocals[iterTmpIndex]);
2674     Tcl_Obj *oldValuePtr = iterVarPtr->value.objPtr;
2675    
2676     if (oldValuePtr == NULL) {
2677     iterVarPtr->value.objPtr = Tcl_NewLongObj(-1);
2678     Tcl_IncrRefCount(iterVarPtr->value.objPtr);
2679     } else {
2680     Tcl_SetLongObj(oldValuePtr, -1);
2681     }
2682     TclSetVarScalar(iterVarPtr);
2683     TclClearVarUndefined(iterVarPtr);
2684     TRACE(("%u => loop iter count temp %d\n",
2685     opnd, iterTmpIndex));
2686     }
2687     ADJUST_PC(5);
2688    
2689     case INST_FOREACH_STEP4:
2690     opnd = TclGetUInt4AtPtr(pc+1);
2691     {
2692     /*
2693     * "Step" a foreach loop (i.e., begin its next iteration) by
2694     * assigning the next value list element to each loop var.
2695     */
2696    
2697     ForeachInfo *infoPtr = (ForeachInfo *)
2698     codePtr->auxDataArrayPtr[opnd].clientData;
2699     ForeachVarList *varListPtr;
2700     int numLists = infoPtr->numLists;
2701     Var *compiledLocals = iPtr->varFramePtr->compiledLocals;
2702     Tcl_Obj *listPtr;
2703     List *listRepPtr;
2704     Var *iterVarPtr, *listVarPtr;
2705     int iterNum, listTmpIndex, listLen, numVars;
2706     int varIndex, valIndex, continueLoop, j;
2707    
2708     /*
2709     * Increment the temp holding the loop iteration number.
2710     */
2711    
2712     iterVarPtr = &(compiledLocals[infoPtr->loopCtTemp]);
2713     valuePtr = iterVarPtr->value.objPtr;
2714     iterNum = (valuePtr->internalRep.longValue + 1);
2715     Tcl_SetLongObj(valuePtr, iterNum);
2716    
2717     /*
2718     * Check whether all value lists are exhausted and we should
2719     * stop the loop.
2720     */
2721    
2722     continueLoop = 0;
2723     listTmpIndex = infoPtr->firstValueTemp;
2724     for (i = 0; i < numLists; i++) {
2725     varListPtr = infoPtr->varLists[i];
2726     numVars = varListPtr->numVars;
2727    
2728     listVarPtr = &(compiledLocals[listTmpIndex]);
2729     listPtr = listVarPtr->value.objPtr;
2730     result = Tcl_ListObjLength(interp, listPtr, &listLen);
2731     if (result != TCL_OK) {
2732     TRACE_WITH_OBJ(("%u => ERROR converting list %ld, \"%s\": ",
2733     opnd, i, O2S(listPtr)),
2734     Tcl_GetObjResult(interp));
2735     goto checkForCatch;
2736     }
2737     if (listLen > (iterNum * numVars)) {
2738     continueLoop = 1;
2739     }
2740     listTmpIndex++;
2741     }
2742    
2743     /*
2744     * If some var in some var list still has a remaining list
2745     * element iterate one more time. Assign to var the next
2746     * element from its value list. We already checked above
2747     * that each list temp holds a valid list object.
2748     */
2749    
2750     if (continueLoop) {
2751     listTmpIndex = infoPtr->firstValueTemp;
2752     for (i = 0; i < numLists; i++) {
2753     varListPtr = infoPtr->varLists[i];
2754     numVars = varListPtr->numVars;
2755    
2756     listVarPtr = &(compiledLocals[listTmpIndex]);
2757     listPtr = listVarPtr->value.objPtr;
2758     listRepPtr = (List *) listPtr->internalRep.otherValuePtr;
2759     listLen = listRepPtr->elemCount;
2760    
2761     valIndex = (iterNum * numVars);
2762     for (j = 0; j < numVars; j++) {
2763     int setEmptyStr = 0;
2764     if (valIndex >= listLen) {
2765     setEmptyStr = 1;
2766     valuePtr = Tcl_NewObj();
2767     } else {
2768     valuePtr = listRepPtr->elements[valIndex];
2769     }
2770    
2771     varIndex = varListPtr->varIndexes[j];
2772     DECACHE_STACK_INFO();
2773     value2Ptr = TclSetIndexedScalar(interp,
2774     varIndex, valuePtr, /*leaveErrorMsg*/ 1);
2775     CACHE_STACK_INFO();
2776     if (value2Ptr == NULL) {
2777     TRACE_WITH_OBJ(("%u => ERROR init. index temp %d: ",
2778     opnd, varIndex),
2779     Tcl_GetObjResult(interp));
2780     if (setEmptyStr) {
2781     Tcl_DecrRefCount(valuePtr);
2782     }
2783     result = TCL_ERROR;
2784     goto checkForCatch;
2785     }
2786     valIndex++;
2787     }
2788     listTmpIndex++;
2789     }
2790     }
2791    
2792     /*
2793     * Push 1 if at least one value list had a remaining element
2794     * and the loop should continue. Otherwise push 0.
2795     */
2796    
2797     PUSH_OBJECT(Tcl_NewLongObj(continueLoop));
2798     TRACE(("%u => %d lists, iter %d, %s loop\n",
2799     opnd, numLists, iterNum,
2800     (continueLoop? "continue" : "exit")));
2801     }
2802     ADJUST_PC(5);
2803    
2804     case INST_BEGIN_CATCH4:
2805     /*
2806     * Record start of the catch command with exception range index
2807     * equal to the operand. Push the current stack depth onto the
2808     * special catch stack.
2809     */
2810     catchStackPtr[++catchTop] = stackTop;
2811     TRACE(("%u => catchTop=%d, stackTop=%d\n",
2812     TclGetUInt4AtPtr(pc+1), catchTop, stackTop));
2813     ADJUST_PC(5);
2814    
2815     case INST_END_CATCH:
2816     catchTop--;
2817     result = TCL_OK;
2818     TRACE(("=> catchTop=%d\n", catchTop));
2819     ADJUST_PC(1);
2820    
2821     case INST_PUSH_RESULT:
2822     PUSH_OBJECT(Tcl_GetObjResult(interp));
2823     TRACE_WITH_OBJ(("=> "), Tcl_GetObjResult(interp));
2824     ADJUST_PC(1);
2825    
2826     case INST_PUSH_RETURN_CODE:
2827     PUSH_OBJECT(Tcl_NewLongObj(result));
2828     TRACE(("=> %u\n", result));
2829     ADJUST_PC(1);
2830    
2831     default:
2832     panic("TclExecuteByteCode: unrecognized opCode %u", *pc);
2833     } /* end of switch on opCode */
2834    
2835     /*
2836     * Division by zero in an expression. Control only reaches this
2837     * point by "goto divideByZero".
2838     */
2839    
2840     divideByZero:
2841     Tcl_ResetResult(interp);
2842     Tcl_AppendToObj(Tcl_GetObjResult(interp), "divide by zero", -1);
2843     Tcl_SetErrorCode(interp, "ARITH", "DIVZERO", "divide by zero",
2844     (char *) NULL);
2845     result = TCL_ERROR;
2846    
2847     /*
2848     * Execution has generated an "exception" such as TCL_ERROR. If the
2849     * exception is an error, record information about what was being
2850     * executed when the error occurred. Find the closest enclosing
2851     * catch range, if any. If no enclosing catch range is found, stop
2852     * execution and return the "exception" code.
2853     */
2854    
2855     checkForCatch:
2856     if ((result == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) {
2857     bytes = GetSrcInfoForPc(pc, codePtr, &length);
2858     if (bytes != NULL) {
2859     Tcl_LogCommandInfo(interp, codePtr->source, bytes, length);
2860     iPtr->flags |= ERR_ALREADY_LOGGED;
2861     }
2862     }
2863     rangePtr = GetExceptRangeForPc(pc, /*catchOnly*/ 1, codePtr);
2864     if (rangePtr == NULL) {
2865     #ifdef TCL_COMPILE_DEBUG
2866     if (traceInstructions) {
2867     fprintf(stdout, " ... no enclosing catch, returning %s\n",
2868     StringForResultCode(result));
2869     }
2870     #endif
2871     goto abnormalReturn;
2872     }
2873    
2874     /*
2875     * A catch exception range (rangePtr) was found to handle an
2876     * "exception". It was found either by checkForCatch just above or
2877     * by an instruction during break, continue, or error processing.
2878     * Jump to its catchOffset after unwinding the operand stack to
2879     * the depth it had when starting to execute the range's catch
2880     * command.
2881     */
2882    
2883     processCatch:
2884     while (stackTop > catchStackPtr[catchTop]) {
2885     valuePtr = POP_OBJECT();
2886     TclDecrRefCount(valuePtr);
2887     }
2888     #ifdef TCL_COMPILE_DEBUG
2889     if (traceInstructions) {
2890     fprintf(stdout, " ... found catch at %d, catchTop=%d, unwound to %d, new pc %u\n",
2891     rangePtr->codeOffset, catchTop, catchStackPtr[catchTop],
2892     (unsigned int)(rangePtr->catchOffset));
2893     }
2894     #endif
2895     pc = (codePtr->codeStart + rangePtr->catchOffset);
2896     continue; /* restart the execution loop at pc */
2897     } /* end of infinite loop dispatching on instructions */
2898    
2899     /*
2900     * Abnormal return code. Restore the stack to state it had when starting
2901     * to execute the ByteCode.
2902     */
2903    
2904     abnormalReturn:
2905     while (stackTop > initStackTop) {
2906     valuePtr = POP_OBJECT();
2907     Tcl_DecrRefCount(valuePtr);
2908     }
2909    
2910     /*
2911     * Free the catch stack array if malloc'ed storage was used.
2912     */
2913    
2914     done:
2915     if (catchStackPtr != catchStackStorage) {
2916     ckfree((char *) catchStackPtr);
2917     }
2918     eePtr->stackTop = initStackTop;
2919     return result;
2920     #undef STATIC_CATCH_STACK_SIZE
2921     }
2922    
2923     #ifdef TCL_COMPILE_DEBUG
2924     /*
2925     *----------------------------------------------------------------------
2926     *
2927     * PrintByteCodeInfo --
2928     *
2929     * This procedure prints a summary about a bytecode object to stdout.
2930     * It is called by TclExecuteByteCode when starting to execute the
2931     * bytecode object if tclTraceExec has the value 2 or more.
2932     *
2933     * Results:
2934     * None.
2935     *
2936     * Side effects:
2937     * None.
2938     *
2939     *----------------------------------------------------------------------
2940     */
2941    
2942     static void
2943     PrintByteCodeInfo(codePtr)
2944     register ByteCode *codePtr; /* The bytecode whose summary is printed
2945     * to stdout. */
2946     {
2947     Proc *procPtr = codePtr->procPtr;
2948     Interp *iPtr = (Interp *) *codePtr->interpHandle;
2949    
2950     fprintf(stdout, "\nExecuting ByteCode 0x%x, refCt %u, epoch %u, interp 0x%x (epoch %u)\n",
2951     (unsigned int) codePtr, codePtr->refCount,
2952     codePtr->compileEpoch, (unsigned int) iPtr,
2953     iPtr->compileEpoch);
2954    
2955     fprintf(stdout, " Source: ");
2956     TclPrintSource(stdout, codePtr->source, 60);
2957    
2958     fprintf(stdout, "\n Cmds %d, src %d, inst %u, litObjs %u, aux %d, stkDepth %u, code/src %.2f\n",
2959     codePtr->numCommands, codePtr->numSrcBytes,
2960     codePtr->numCodeBytes, codePtr->numLitObjects,
2961     codePtr->numAuxDataItems, codePtr->maxStackDepth,
2962     #ifdef TCL_COMPILE_STATS
2963     (codePtr->numSrcBytes?
2964     ((float)codePtr->structureSize)/((float)codePtr->numSrcBytes) : 0.0));
2965     #else
2966     0.0);
2967     #endif
2968     #ifdef TCL_COMPILE_STATS
2969     fprintf(stdout, " Code %d = header %d+inst %d+litObj %d+exc %d+aux %d+cmdMap %d\n",
2970     codePtr->structureSize,
2971     (sizeof(ByteCode) - (sizeof(size_t) + sizeof(Tcl_Time))),
2972     codePtr->numCodeBytes,
2973     (codePtr->numLitObjects * sizeof(Tcl_Obj *)),
2974     (codePtr->numExceptRanges * sizeof(ExceptionRange)),
2975     (codePtr->numAuxDataItems * sizeof(AuxData)),
2976     codePtr->numCmdLocBytes);
2977     #endif /* TCL_COMPILE_STATS */
2978     if (procPtr != NULL) {
2979     fprintf(stdout,
2980     " Proc 0x%x, refCt %d, args %d, compiled locals %d\n",
2981     (unsigned int) procPtr, procPtr->refCount,
2982     procPtr->numArgs, procPtr->numCompiledLocals);
2983     }
2984     }
2985     #endif /* TCL_COMPILE_DEBUG */
2986    
2987     /*
2988     *----------------------------------------------------------------------
2989     *
2990     * ValidatePcAndStackTop --
2991     *
2992     * This procedure is called by TclExecuteByteCode when debugging to
2993     * verify that the program counter and stack top are valid during
2994     * execution.
2995     *
2996     * Results:
2997     * None.
2998     *
2999     * Side effects:
3000     * Prints a message to stderr and panics if either the pc or stack
3001     * top are invalid.
3002     *
3003     *----------------------------------------------------------------------
3004     */
3005    
3006     #ifdef TCL_COMPILE_DEBUG
3007     static void
3008     ValidatePcAndStackTop(codePtr, pc, stackTop, stackLowerBound,
3009     stackUpperBound)
3010     register ByteCode *codePtr; /* The bytecode whose summary is printed
3011     * to stdout. */
3012     unsigned char *pc; /* Points to first byte of a bytecode
3013     * instruction. The program counter. */
3014     int stackTop; /* Current stack top. Must be between
3015     * stackLowerBound and stackUpperBound
3016     * (inclusive). */
3017     int stackLowerBound; /* Smallest legal value for stackTop. */
3018     int stackUpperBound; /* Greatest legal value for stackTop. */
3019     {
3020     unsigned int relativePc = (unsigned int) (pc - codePtr->codeStart);
3021     unsigned int codeStart = (unsigned int) codePtr->codeStart;
3022     unsigned int codeEnd = (unsigned int)
3023     (codePtr->codeStart + codePtr->numCodeBytes);
3024     unsigned char opCode = *pc;
3025    
3026     if (((unsigned int) pc < codeStart) || ((unsigned int) pc > codeEnd)) {
3027     fprintf(stderr, "\nBad instruction pc 0x%x in TclExecuteByteCode\n",
3028     (unsigned int) pc);
3029     panic("TclExecuteByteCode execution failure: bad pc");
3030     }
3031     if ((unsigned int) opCode > LAST_INST_OPCODE) {
3032     fprintf(stderr, "\nBad opcode %d at pc %u in TclExecuteByteCode\n",
3033     (unsigned int) opCode, relativePc);
3034     panic("TclExecuteByteCode execution failure: bad opcode");
3035     }
3036     if ((stackTop < stackLowerBound) || (stackTop > stackUpperBound)) {
3037     int numChars;
3038     char *cmd = GetSrcInfoForPc(pc, codePtr, &numChars);
3039     char *ellipsis = "";
3040    
3041     fprintf(stderr, "\nBad stack top %d at pc %u in TclExecuteByteCode",
3042     stackTop, relativePc);
3043     if (cmd != NULL) {
3044     if (numChars > 100) {
3045     numChars = 100;
3046     ellipsis = "...";
3047     }
3048     fprintf(stderr, "\n executing %.*s%s\n", numChars, cmd,
3049     ellipsis);
3050     } else {
3051     fprintf(stderr, "\n");
3052     }
3053     panic("TclExecuteByteCode execution failure: bad stack top");
3054     }
3055     }
3056     #endif /* TCL_COMPILE_DEBUG */
3057    
3058     /*
3059     *----------------------------------------------------------------------
3060     *
3061     * IllegalExprOperandType --
3062     *
3063     * Used by TclExecuteByteCode to add an error message to errorInfo
3064     * when an illegal operand type is detected by an expression
3065     * instruction. The argument opndPtr holds the operand object in error.
3066     *
3067     * Results:
3068     * None.
3069     *
3070     * Side effects:
3071     * An error message is appended to errorInfo.
3072     *
3073     *----------------------------------------------------------------------
3074     */
3075    
3076     static void
3077     IllegalExprOperandType(interp, pc, opndPtr)
3078     Tcl_Interp *interp; /* Interpreter to which error information
3079     * pertains. */
3080     unsigned char *pc; /* Points to the instruction being executed
3081     * when the illegal type was found. */
3082     Tcl_Obj *opndPtr; /* Points to the operand holding the value
3083     * with the illegal type. */
3084     {
3085     unsigned char opCode = *pc;
3086    
3087     Tcl_ResetResult(interp);
3088     if ((opndPtr->bytes == NULL) || (opndPtr->length == 0)) {
3089     Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
3090     "can't use empty string as operand of \"",
3091     operatorStrings[opCode - INST_LOR], "\"", (char *) NULL);
3092     } else {
3093     char *msg = "non-numeric string";
3094     if (opndPtr->typePtr != &tclDoubleType) {
3095     /*
3096     * See if the operand can be interpreted as a double in order to
3097     * improve the error message.
3098     */
3099    
3100     char *s = Tcl_GetString(opndPtr);
3101     double d;
3102    
3103     if (Tcl_GetDouble((Tcl_Interp *) NULL, s, &d) == TCL_OK) {
3104     /*
3105     * Make sure that what appears to be a double
3106     * (ie 08) isn't really a bad octal
3107     */
3108     if (TclCheckBadOctal(NULL, Tcl_GetString(opndPtr))) {
3109     msg = "invalid octal number";
3110     } else {
3111     msg = "floating-point value";
3112     }
3113     }
3114     }
3115     Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "can't use ",
3116     msg, " as operand of \"", operatorStrings[opCode - INST_LOR],
3117     "\"", (char *) NULL);
3118     }
3119     }
3120    
3121     /*
3122     *----------------------------------------------------------------------
3123     *
3124     * CallTraceProcedure --
3125     *
3126     * Invokes a trace procedure registered with an interpreter. These
3127     * procedures trace command execution. Currently this trace procedure
3128     * is called with the address of the string-based Tcl_CmdProc for the
3129     * command, not the Tcl_ObjCmdProc.
3130     *
3131     * Results:
3132     * None.
3133     *
3134     * Side effects:
3135     * Those side effects made by the trace procedure.
3136     *
3137     *----------------------------------------------------------------------
3138     */
3139    
3140     static void
3141     CallTraceProcedure(interp, tracePtr, cmdPtr, command, numChars, objc, objv)
3142     Tcl_Interp *interp; /* The current interpreter. */
3143     register Trace *tracePtr; /* Describes the trace procedure to call. */
3144     Command *cmdPtr; /* Points to command's Command struct. */
3145     char *command; /* Points to the first character of the
3146     * command's source before substitutions. */
3147     int numChars; /* The number of characters in the
3148     * command's source. */
3149     register int objc; /* Number of arguments for the command. */
3150     Tcl_Obj *objv[]; /* Pointers to Tcl_Obj of each argument. */
3151     {
3152     Interp *iPtr = (Interp *) interp;
3153     register char **argv;
3154     register int i;
3155     int length;
3156     char *p;
3157    
3158     /*
3159     * Get the string rep from the objv argument objects and place their
3160     * pointers in argv. First make sure argv is large enough to hold the
3161     * objc args plus 1 extra word for the zero end-of-argv word.
3162     */
3163    
3164     argv = (char **) ckalloc((unsigned)(objc + 1) * sizeof(char *));
3165     for (i = 0; i < objc; i++) {
3166     argv[i] = Tcl_GetStringFromObj(objv[i], &length);
3167     }
3168     argv[objc] = 0;
3169    
3170     /*
3171     * Copy the command characters into a new string.
3172     */
3173    
3174     p = (char *) ckalloc((unsigned) (numChars + 1));
3175     memcpy((VOID *) p, (VOID *) command, (size_t) numChars);
3176     p[numChars] = '\0';
3177    
3178     /*
3179     * Call the trace procedure then free allocated storage.
3180     */
3181    
3182     (*tracePtr->proc)(tracePtr->clientData, interp, iPtr->numLevels,
3183     p, cmdPtr->proc, cmdPtr->clientData, objc, argv);
3184    
3185     ckfree((char *) argv);
3186     ckfree((char *) p);
3187     }
3188    
3189     /*
3190     *----------------------------------------------------------------------
3191     *
3192     * GetSrcInfoForPc --
3193     *
3194     * Given a program counter value, finds the closest command in the
3195     * bytecode code unit's CmdLocation array and returns information about
3196     * that command's source: a pointer to its first byte and the number of
3197     * characters.
3198     *
3199     * Results:
3200     * If a command is found that encloses the program counter value, a
3201     * pointer to the command's source is returned and the length of the
3202     * source is stored at *lengthPtr. If multiple commands resulted in
3203     * code at pc, information about the closest enclosing command is
3204     * returned. If no matching command is found, NULL is returned and
3205     * *lengthPtr is unchanged.
3206     *
3207     * Side effects:
3208     * None.
3209     *
3210     *----------------------------------------------------------------------
3211     */
3212    
3213     static char *
3214     GetSrcInfoForPc(pc, codePtr, lengthPtr)
3215     unsigned char *pc; /* The program counter value for which to
3216     * return the closest command's source info.
3217     * This points to a bytecode instruction
3218     * in codePtr's code. */
3219     ByteCode *codePtr; /* The bytecode sequence in which to look
3220     * up the command source for the pc. */
3221     int *lengthPtr; /* If non-NULL, the location where the
3222     * length of the command's source should be
3223     * stored. If NULL, no length is stored. */
3224     {
3225     register int pcOffset = (pc - codePtr->codeStart);
3226     int numCmds = codePtr->numCommands;
3227     unsigned char *codeDeltaNext, *codeLengthNext;
3228     unsigned char *srcDeltaNext, *srcLengthNext;
3229     int codeOffset, codeLen, codeEnd, srcOffset, srcLen, delta, i;
3230     int bestDist = INT_MAX; /* Distance of pc to best cmd's start pc. */
3231     int bestSrcOffset = -1; /* Initialized to avoid compiler warning. */
3232     int bestSrcLength = -1; /* Initialized to avoid compiler warning. */
3233    
3234     if ((pcOffset < 0) || (pcOffset >= codePtr->numCodeBytes)) {
3235     return NULL;
3236     }
3237    
3238     /*
3239     * Decode the code and source offset and length for each command. The
3240     * closest enclosing command is the last one whose code started before
3241     * pcOffset.
3242     */
3243    
3244     codeDeltaNext = codePtr->codeDeltaStart;
3245     codeLengthNext = codePtr->codeLengthStart;
3246     srcDeltaNext = codePtr->srcDeltaStart;
3247     srcLengthNext = codePtr->srcLengthStart;
3248     codeOffset = srcOffset = 0;
3249     for (i = 0; i < numCmds; i++) {
3250     if ((unsigned int) (*codeDeltaNext) == (unsigned int) 0xFF) {
3251     codeDeltaNext++;
3252     delta = TclGetInt4AtPtr(codeDeltaNext);
3253     codeDeltaNext += 4;
3254     } else {
3255     delta = TclGetInt1AtPtr(codeDeltaNext);
3256     codeDeltaNext++;
3257     }
3258     codeOffset += delta;
3259    
3260     if ((unsigned int) (*codeLengthNext) == (unsigned int) 0xFF) {
3261     codeLengthNext++;
3262     codeLen = TclGetInt4AtPtr(codeLengthNext);
3263     codeLengthNext += 4;
3264     } else {
3265     codeLen = TclGetInt1AtPtr(codeLengthNext);
3266     codeLengthNext++;
3267     }
3268     codeEnd = (codeOffset + codeLen - 1);
3269    
3270     if ((unsigned int) (*srcDeltaNext) == (unsigned int) 0xFF) {
3271     srcDeltaNext++;
3272     delta = TclGetInt4AtPtr(srcDeltaNext);
3273     srcDeltaNext += 4;
3274     } else {
3275     delta = TclGetInt1AtPtr(srcDeltaNext);
3276     srcDeltaNext++;
3277     }
3278     srcOffset += delta;
3279    
3280     if ((unsigned int) (*srcLengthNext) == (unsigned int) 0xFF) {
3281     srcLengthNext++;
3282     srcLen = TclGetInt4AtPtr(srcLengthNext);
3283     srcLengthNext += 4;
3284     } else {
3285     srcLen = TclGetInt1AtPtr(srcLengthNext);
3286     srcLengthNext++;
3287     }
3288    
3289     if (codeOffset > pcOffset) { /* best cmd already found */
3290     break;
3291     } else if (pcOffset <= codeEnd) { /* this cmd's code encloses pc */
3292     int dist = (pcOffset - codeOffset);
3293     if (dist <= bestDist) {
3294     bestDist = dist;
3295     bestSrcOffset = srcOffset;
3296     bestSrcLength = srcLen;
3297     }
3298     }
3299     }
3300    
3301     if (bestDist == INT_MAX) {
3302     return NULL;
3303     }
3304    
3305     if (lengthPtr != NULL) {
3306     *lengthPtr = bestSrcLength;
3307     }
3308     return (codePtr->source + bestSrcOffset);
3309     }
3310    
3311     /*
3312     *----------------------------------------------------------------------
3313     *
3314     * GetExceptRangeForPc --
3315     *
3316     * Given a program counter value, return the closest enclosing
3317     * ExceptionRange.
3318     *
3319     * Results:
3320     * In the normal case, catchOnly is 0 (false) and this procedure
3321     * returns a pointer to the most closely enclosing ExceptionRange
3322     * structure regardless of whether it is a loop or catch exception
3323     * range. This is appropriate when processing a TCL_BREAK or
3324     * TCL_CONTINUE, which will be "handled" either by a loop exception
3325     * range or a closer catch range. If catchOnly is nonzero, this
3326     * procedure ignores loop exception ranges and returns a pointer to the
3327     * closest catch range. If no matching ExceptionRange is found that
3328     * encloses pc, a NULL is returned.
3329     *
3330     * Side effects:
3331     * None.
3332     *
3333     *----------------------------------------------------------------------
3334     */
3335    
3336     static ExceptionRange *
3337     GetExceptRangeForPc(pc, catchOnly, codePtr)
3338     unsigned char *pc; /* The program counter value for which to
3339     * search for a closest enclosing exception
3340     * range. This points to a bytecode
3341     * instruction in codePtr's code. */
3342     int catchOnly; /* If 0, consider either loop or catch
3343     * ExceptionRanges in search. If nonzero
3344     * consider only catch ranges (and ignore
3345     * any closer loop ranges). */
3346     ByteCode* codePtr; /* Points to the ByteCode in which to search
3347     * for the enclosing ExceptionRange. */
3348     {
3349     ExceptionRange *rangeArrayPtr;
3350     int numRanges = codePtr->numExceptRanges;
3351     register ExceptionRange *rangePtr;
3352     int pcOffset = (pc - codePtr->codeStart);
3353     register int i, level;
3354    
3355     if (numRanges == 0) {
3356     return NULL;
3357     }
3358     rangeArrayPtr = codePtr->exceptArrayPtr;
3359    
3360     for (level = codePtr->maxExceptDepth; level >= 0; level--) {
3361     for (i = 0; i < numRanges; i++) {
3362     rangePtr = &(rangeArrayPtr[i]);
3363     if (rangePtr->nestingLevel == level) {
3364     int start = rangePtr->codeOffset;
3365     int end = (start + rangePtr->numCodeBytes);
3366     if ((start <= pcOffset) && (pcOffset < end)) {
3367     if ((!catchOnly)
3368     || (rangePtr->type == CATCH_EXCEPTION_RANGE)) {
3369     return rangePtr;
3370     }
3371     }
3372     }
3373     }
3374     }
3375     return NULL;
3376     }
3377    
3378     /*
3379     *----------------------------------------------------------------------
3380     *
3381     * GetOpcodeName --
3382     *
3383     * This procedure is called by the TRACE and TRACE_WITH_OBJ macros
3384     * used in TclExecuteByteCode when debugging. It returns the name of
3385     * the bytecode instruction at a specified instruction pc.
3386     *
3387     * Results:
3388     * A character string for the instruction.
3389     *
3390     * Side effects:
3391     * None.
3392     *
3393     *----------------------------------------------------------------------
3394     */
3395    
3396     #ifdef TCL_COMPILE_DEBUG
3397     static char *
3398     GetOpcodeName(pc)
3399     unsigned char *pc; /* Points to the instruction whose name
3400     * should be returned. */
3401     {
3402     unsigned char opCode = *pc;
3403    
3404     return instructionTable[opCode].name;
3405     }
3406     #endif /* TCL_COMPILE_DEBUG */
3407    
3408     /*
3409     *----------------------------------------------------------------------
3410     *
3411     * VerifyExprObjType --
3412     *
3413     * This procedure is called by the math functions to verify that
3414     * the object is either an int or double, coercing it if necessary.
3415     * If an error occurs during conversion, an error message is left
3416     * in the interpreter's result unless "interp" is NULL.
3417     *
3418     * Results:
3419     * TCL_OK if it was int or double, TCL_ERROR otherwise
3420     *
3421     * Side effects:
3422     * objPtr is ensured to be either tclIntType of tclDoubleType.
3423     *
3424     *----------------------------------------------------------------------
3425     */
3426    
3427     static int
3428     VerifyExprObjType(interp, objPtr)
3429     Tcl_Interp *interp; /* The interpreter in which to execute the
3430     * function. */
3431     Tcl_Obj *objPtr; /* Points to the object to type check. */
3432     {
3433     if ((objPtr->typePtr == &tclIntType) ||
3434     (objPtr->typePtr == &tclDoubleType)) {
3435     return TCL_OK;
3436     } else {
3437     int length, result = TCL_OK;
3438     char *s = Tcl_GetStringFromObj(objPtr, &length);
3439    
3440     if (TclLooksLikeInt(s, length)) {
3441     long i;
3442     result = Tcl_GetLongFromObj((Tcl_Interp *) NULL, objPtr, &i);
3443     } else {
3444     double d;
3445     result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL, objPtr, &d);
3446     }
3447     if ((result != TCL_OK) && (interp != NULL)) {
3448     Tcl_ResetResult(interp);
3449     if (TclCheckBadOctal((Tcl_Interp *) NULL, s)) {
3450     Tcl_AppendToObj(Tcl_GetObjResult(interp),
3451     "argument to math function was an invalid octal number",
3452     -1);
3453     } else {
3454     Tcl_AppendToObj(Tcl_GetObjResult(interp),
3455     "argument to math function didn't have numeric value",
3456     -1);
3457     }
3458     }
3459     return result;
3460     }
3461     }
3462    
3463     /*
3464     *----------------------------------------------------------------------
3465     *
3466     * Math Functions --
3467     *
3468     * This page contains the procedures that implement all of the
3469     * built-in math functions for expressions.
3470     *
3471     * Results:
3472     * Each procedure returns TCL_OK if it succeeds and pushes an
3473     * Tcl object holding the result. If it fails it returns TCL_ERROR
3474     * and leaves an error message in the interpreter's result.
3475     *
3476     * Side effects:
3477     * None.
3478     *
3479     *----------------------------------------------------------------------
3480     */
3481    
3482     static int
3483     ExprUnaryFunc(interp, eePtr, clientData)
3484     Tcl_Interp *interp; /* The interpreter in which to execute the
3485     * function. */
3486     ExecEnv *eePtr; /* Points to the environment for executing
3487     * the function. */
3488     ClientData clientData; /* Contains the address of a procedure that
3489     * takes one double argument and returns a
3490     * double result. */
3491     {
3492     Tcl_Obj **stackPtr; /* Cached evaluation stack base pointer. */
3493     register int stackTop; /* Cached top index of evaluation stack. */
3494     register Tcl_Obj *valuePtr;
3495     double d, dResult;
3496     int result;
3497    
3498     double (*func) _ANSI_ARGS_((double)) =
3499     (double (*)_ANSI_ARGS_((double))) clientData;
3500    
3501     /*
3502     * Set stackPtr and stackTop from eePtr.
3503     */
3504    
3505     result = TCL_OK;
3506     CACHE_STACK_INFO();
3507    
3508     /*
3509     * Pop the function's argument from the evaluation stack. Convert it
3510     * to a double if necessary.
3511     */
3512    
3513     valuePtr = POP_OBJECT();
3514    
3515     if (VerifyExprObjType(interp, valuePtr) != TCL_OK) {
3516     result = TCL_ERROR;
3517     goto done;
3518     }
3519    
3520     if (valuePtr->typePtr == &tclIntType) {
3521     d = (double) valuePtr->internalRep.longValue;
3522     } else {
3523     d = valuePtr->internalRep.doubleValue;
3524     }
3525    
3526     errno = 0;
3527     dResult = (*func)(d);
3528     if ((errno != 0) || IS_NAN(dResult) || IS_INF(dResult)) {
3529     TclExprFloatError(interp, dResult);
3530     result = TCL_ERROR;
3531     goto done;
3532     }
3533    
3534     /*
3535     * Push a Tcl object holding the result.
3536     */
3537    
3538     PUSH_OBJECT(Tcl_NewDoubleObj(dResult));
3539    
3540     /*
3541     * Reflect the change to stackTop back in eePtr.
3542     */
3543    
3544     done:
3545     Tcl_DecrRefCount(valuePtr);
3546     DECACHE_STACK_INFO();
3547     return result;
3548     }
3549    
3550     static int
3551     ExprBinaryFunc(interp, eePtr, clientData)
3552     Tcl_Interp *interp; /* The interpreter in which to execute the
3553     * function. */
3554     ExecEnv *eePtr; /* Points to the environment for executing
3555     * the function. */
3556     ClientData clientData; /* Contains the address of a procedure that
3557     * takes two double arguments and
3558     * returns a double result. */
3559     {
3560     Tcl_Obj **stackPtr; /* Cached evaluation stack base pointer. */
3561     register int stackTop; /* Cached top index of evaluation stack. */
3562     register Tcl_Obj *valuePtr, *value2Ptr;
3563     double d1, d2, dResult;
3564     int result;
3565    
3566     double (*func) _ANSI_ARGS_((double, double))
3567     = (double (*)_ANSI_ARGS_((double, double))) clientData;
3568    
3569     /*
3570     * Set stackPtr and stackTop from eePtr.
3571     */
3572    
3573     result = TCL_OK;
3574     CACHE_STACK_INFO();
3575    
3576     /*
3577     * Pop the function's two arguments from the evaluation stack. Convert
3578     * them to doubles if necessary.
3579     */
3580    
3581     value2Ptr = POP_OBJECT();
3582     valuePtr = POP_OBJECT();
3583    
3584     if ((VerifyExprObjType(interp, valuePtr) != TCL_OK) ||
3585     (VerifyExprObjType(interp, value2Ptr) != TCL_OK)) {
3586     result = TCL_ERROR;
3587     goto done;
3588     }
3589    
3590     if (valuePtr->typePtr == &tclIntType) {
3591     d1 = (double) valuePtr->internalRep.longValue;
3592     } else {
3593     d1 = valuePtr->internalRep.doubleValue;
3594     }
3595    
3596     if (value2Ptr->typePtr == &tclIntType) {
3597     d2 = (double) value2Ptr->internalRep.longValue;
3598     } else {
3599     d2 = value2Ptr->internalRep.doubleValue;
3600     }
3601    
3602     errno = 0;
3603     dResult = (*func)(d1, d2);
3604     if ((errno != 0) || IS_NAN(dResult) || IS_INF(dResult)) {
3605     TclExprFloatError(interp, dResult);
3606     result = TCL_ERROR;
3607     goto done;
3608     }
3609    
3610     /*
3611     * Push a Tcl object holding the result.
3612     */
3613    
3614     PUSH_OBJECT(Tcl_NewDoubleObj(dResult));
3615    
3616     /*
3617     * Reflect the change to stackTop back in eePtr.
3618     */
3619    
3620     done:
3621     Tcl_DecrRefCount(valuePtr);
3622     Tcl_DecrRefCount(value2Ptr);
3623     DECACHE_STACK_INFO();
3624     return result;
3625     }
3626    
3627     static int
3628     ExprAbsFunc(interp, eePtr, clientData)
3629     Tcl_Interp *interp; /* The interpreter in which to execute the
3630     * function. */
3631     ExecEnv *eePtr; /* Points to the environment for executing
3632     * the function. */
3633     ClientData clientData; /* Ignored. */
3634     {
3635     Tcl_Obj **stackPtr; /* Cached evaluation stack base pointer. */
3636     register int stackTop; /* Cached top index of evaluation stack. */
3637     register Tcl_Obj *valuePtr;
3638     long i, iResult;
3639     double d, dResult;
3640     int result;
3641    
3642     /*
3643     * Set stackPtr and stackTop from eePtr.
3644     */
3645    
3646     result = TCL_OK;
3647     CACHE_STACK_INFO();
3648    
3649     /*
3650     * Pop the argument from the evaluation stack.
3651     */
3652    
3653     valuePtr = POP_OBJECT();
3654    
3655     if (VerifyExprObjType(interp, valuePtr) != TCL_OK) {
3656     result = TCL_ERROR;
3657     goto done;
3658     }
3659    
3660     /*
3661     * Push a Tcl object with the result.
3662     */
3663     if (valuePtr->typePtr == &tclIntType) {
3664     i = valuePtr->internalRep.longValue;
3665     if (i < 0) {
3666     iResult = -i;
3667     if (iResult < 0) {
3668     Tcl_ResetResult(interp);
3669     Tcl_AppendToObj(Tcl_GetObjResult(interp),
3670     "integer value too large to represent", -1);
3671     Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW",
3672     "integer value too large to represent", (char *) NULL);
3673     result = TCL_ERROR;
3674     goto done;
3675     }
3676     } else {
3677     iResult = i;
3678     }
3679     PUSH_OBJECT(Tcl_NewLongObj(iResult));
3680     } else {
3681     d = valuePtr->internalRep.doubleValue;
3682     if (d < 0.0) {
3683     dResult = -d;
3684     } else {
3685     dResult = d;
3686     }
3687     if (IS_NAN(dResult) || IS_INF(dResult)) {
3688     TclExprFloatError(interp, dResult);
3689     result = TCL_ERROR;
3690     goto done;
3691     }
3692     PUSH_OBJECT(Tcl_NewDoubleObj(dResult));
3693     }
3694    
3695     /*
3696     * Reflect the change to stackTop back in eePtr.
3697     */
3698    
3699     done:
3700     Tcl_DecrRefCount(valuePtr);
3701     DECACHE_STACK_INFO();
3702     return result;
3703     }
3704    
3705     static int
3706     ExprDoubleFunc(interp, eePtr, clientData)
3707     Tcl_Interp *interp; /* The interpreter in which to execute the
3708     * function. */
3709     ExecEnv *eePtr; /* Points to the environment for executing
3710     * the function. */
3711     ClientData clientData; /* Ignored. */
3712     {
3713     Tcl_Obj **stackPtr; /* Cached evaluation stack base pointer. */
3714     register int stackTop; /* Cached top index of evaluation stack. */
3715     register Tcl_Obj *valuePtr;
3716     double dResult;
3717     int result;
3718    
3719     /*
3720     * Set stackPtr and stackTop from eePtr.
3721     */
3722    
3723     result = TCL_OK;
3724     CACHE_STACK_INFO();
3725    
3726     /*
3727     * Pop the argument from the evaluation stack.
3728     */
3729    
3730     valuePtr = POP_OBJECT();
3731    
3732     if (VerifyExprObjType(interp, valuePtr) != TCL_OK) {
3733     result = TCL_ERROR;
3734     goto done;
3735     }
3736    
3737     if (valuePtr->typePtr == &tclIntType) {
3738     dResult = (double) valuePtr->internalRep.longValue;
3739     } else {
3740     dResult = valuePtr->internalRep.doubleValue;
3741     }
3742    
3743     /*
3744     * Push a Tcl object with the result.
3745     */
3746    
3747     PUSH_OBJECT(Tcl_NewDoubleObj(dResult));
3748    
3749     /*
3750     * Reflect the change to stackTop back in eePtr.
3751     */
3752    
3753     done:
3754     Tcl_DecrRefCount(valuePtr);
3755     DECACHE_STACK_INFO();
3756     return result;
3757     }
3758    
3759     static int
3760     ExprIntFunc(interp, eePtr, clientData)
3761     Tcl_Interp *interp; /* The interpreter in which to execute the
3762     * function. */
3763     ExecEnv *eePtr; /* Points to the environment for executing
3764     * the function. */
3765     ClientData clientData; /* Ignored. */
3766     {
3767     Tcl_Obj **stackPtr; /* Cached evaluation stack base pointer. */
3768     register int stackTop; /* Cached top index of evaluation stack. */
3769     register Tcl_Obj *valuePtr;
3770     long iResult;
3771     double d;
3772     int result;
3773    
3774     /*
3775     * Set stackPtr and stackTop from eePtr.
3776     */
3777    
3778     result = TCL_OK;
3779     CACHE_STACK_INFO();
3780    
3781     /*
3782     * Pop the argument from the evaluation stack.
3783     */
3784    
3785     valuePtr = POP_OBJECT();
3786    
3787     if (VerifyExprObjType(interp, valuePtr) != TCL_OK) {
3788     result = TCL_ERROR;
3789     goto done;
3790     }
3791    
3792     if (valuePtr->typePtr == &tclIntType) {
3793     iResult = valuePtr->internalRep.longValue;
3794     } else {
3795     d = valuePtr->internalRep.doubleValue;
3796     if (d < 0.0) {
3797     if (d < (double) (long) LONG_MIN) {
3798     tooLarge:
3799     Tcl_ResetResult(interp);
3800     Tcl_AppendToObj(Tcl_GetObjResult(interp),
3801     "integer value too large to represent", -1);
3802     Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW",
3803     "integer value too large to represent", (char *) NULL);
3804     result = TCL_ERROR;
3805     goto done;
3806     }
3807     } else {
3808     if (d > (double) LONG_MAX) {
3809     goto tooLarge;
3810     }
3811     }
3812     if (IS_NAN(d) || IS_INF(d)) {
3813     TclExprFloatError(interp, d);
3814     result = TCL_ERROR;
3815     goto done;
3816     }
3817     iResult = (long) d;
3818     }
3819    
3820     /*
3821     * Push a Tcl object with the result.
3822     */
3823    
3824     PUSH_OBJECT(Tcl_NewLongObj(iResult));
3825    
3826     /*
3827     * Reflect the change to stackTop back in eePtr.
3828     */
3829    
3830     done:
3831     Tcl_DecrRefCount(valuePtr);
3832     DECACHE_STACK_INFO();
3833     return result;
3834     }
3835    
3836     static int
3837     ExprRandFunc(interp, eePtr, clientData)
3838     Tcl_Interp *interp; /* The interpreter in which to execute the
3839     * function. */
3840     ExecEnv *eePtr; /* Points to the environment for executing
3841     * the function. */
3842     ClientData clientData; /* Ignored. */
3843     {
3844     Tcl_Obj **stackPtr; /* Cached evaluation stack base pointer. */
3845     register int stackTop; /* Cached top index of evaluation stack. */
3846     Interp *iPtr = (Interp *) interp;
3847     double dResult;
3848     int tmp;
3849    
3850     if (!(iPtr->flags & RAND_SEED_INITIALIZED)) {
3851     iPtr->flags |= RAND_SEED_INITIALIZED;
3852     iPtr->randSeed = TclpGetClicks();
3853     }
3854    
3855     /*
3856     * Set stackPtr and stackTop from eePtr.
3857     */
3858    
3859     CACHE_STACK_INFO();
3860    
3861     /*
3862     * Generate the random number using the linear congruential
3863     * generator defined by the following recurrence:
3864     * seed = ( IA * seed ) mod IM
3865     * where IA is 16807 and IM is (2^31) - 1. In order to avoid
3866     * potential problems with integer overflow, the code uses
3867     * additional constants IQ and IR such that
3868     * IM = IA*IQ + IR
3869     * For details on how this algorithm works, refer to the following
3870     * papers:
3871     *
3872     * S.K. Park & K.W. Miller, "Random number generators: good ones
3873     * are hard to find," Comm ACM 31(10):1192-1201, Oct 1988
3874     *
3875     * W.H. Press & S.A. Teukolsky, "Portable random number
3876     * generators," Computers in Physics 6(5):522-524, Sep/Oct 1992.
3877     */
3878    
3879     #define RAND_IA 16807
3880     #define RAND_IM 2147483647
3881     #define RAND_IQ 127773
3882     #define RAND_IR 2836
3883     #define RAND_MASK 123459876
3884    
3885     if (iPtr->randSeed == 0) {
3886     /*
3887     * Don't allow a 0 seed, since it breaks the generator. Shift
3888     * it to some other value.
3889     */
3890    
3891     iPtr->randSeed = 123459876;
3892     }
3893     tmp = iPtr->randSeed/RAND_IQ;
3894     iPtr->randSeed = RAND_IA*(iPtr->randSeed - tmp*RAND_IQ) - RAND_IR*tmp;
3895     if (iPtr->randSeed < 0) {
3896     iPtr->randSeed += RAND_IM;
3897     }
3898    
3899     /*
3900     * On 64-bit architectures we need to mask off the upper bits to
3901     * ensure we only have a 32-bit range. The constant has the
3902     * bizarre form below in order to make sure that it doesn't
3903     * get sign-extended (the rules for sign extension are very
3904     * concat, particularly on 64-bit machines).
3905     */
3906    
3907     iPtr->randSeed &= ((((unsigned long) 0xfffffff) << 4) | 0xf);
3908     dResult = iPtr->randSeed * (1.0/RAND_IM);
3909    
3910     /*
3911     * Push a Tcl object with the result.
3912     */
3913    
3914     PUSH_OBJECT(Tcl_NewDoubleObj(dResult));
3915    
3916     /*
3917     * Reflect the change to stackTop back in eePtr.
3918     */
3919    
3920     DECACHE_STACK_INFO();
3921     return TCL_OK;
3922     }
3923    
3924     static int
3925     ExprRoundFunc(interp, eePtr, clientData)
3926     Tcl_Interp *interp; /* The interpreter in which to execute the
3927     * function. */
3928     ExecEnv *eePtr; /* Points to the environment for executing
3929     * the function. */
3930     ClientData clientData; /* Ignored. */
3931     {
3932     Tcl_Obj **stackPtr; /* Cached evaluation stack base pointer. */
3933     register int stackTop; /* Cached top index of evaluation stack. */
3934     Tcl_Obj *valuePtr;
3935     long iResult;
3936     double d, temp;
3937     int result;
3938    
3939     /*
3940     * Set stackPtr and stackTop from eePtr.
3941     */
3942    
3943     result = TCL_OK;
3944     CACHE_STACK_INFO();
3945    
3946     /*
3947     * Pop the argument from the evaluation stack.
3948     */
3949    
3950     valuePtr = POP_OBJECT();
3951    
3952     if (VerifyExprObjType(interp, valuePtr) != TCL_OK) {
3953     result = TCL_ERROR;
3954     goto done;
3955     }
3956    
3957     if (valuePtr->typePtr == &tclIntType) {
3958     iResult = valuePtr->internalRep.longValue;
3959     } else {
3960     d = valuePtr->internalRep.doubleValue;
3961     if (d < 0.0) {
3962     if (d <= (((double) (long) LONG_MIN) - 0.5)) {
3963     tooLarge:
3964     Tcl_ResetResult(interp);
3965     Tcl_AppendToObj(Tcl_GetObjResult(interp),
3966     "integer value too large to represent", -1);
3967     Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW",
3968     "integer value too large to represent",
3969     (char *) NULL);
3970     result = TCL_ERROR;
3971     goto done;
3972     }
3973     temp = (long) (d - 0.5);
3974     } else {
3975     if (d >= (((double) LONG_MAX + 0.5))) {
3976     goto tooLarge;
3977     }
3978     temp = (long) (d + 0.5);
3979     }
3980     if (IS_NAN(temp) || IS_INF(temp)) {
3981     TclExprFloatError(interp, temp);
3982     result = TCL_ERROR;
3983     goto done;
3984     }
3985     iResult = (long) temp;
3986     }
3987    
3988     /*
3989     * Push a Tcl object with the result.
3990     */
3991    
3992     PUSH_OBJECT(Tcl_NewLongObj(iResult));
3993    
3994     /*
3995     * Reflect the change to stackTop back in eePtr.
3996     */
3997    
3998     done:
3999     Tcl_DecrRefCount(valuePtr);
4000     DECACHE_STACK_INFO();
4001     return result;
4002     }
4003    
4004     static int
4005     ExprSrandFunc(interp, eePtr, clientData)
4006     Tcl_Interp *interp; /* The interpreter in which to execute the
4007     * function. */
4008     ExecEnv *eePtr; /* Points to the environment for executing
4009     * the function. */
4010     ClientData clientData; /* Ignored. */
4011     {
4012     Tcl_Obj **stackPtr; /* Cached evaluation stack base pointer. */
4013     register int stackTop; /* Cached top index of evaluation stack. */
4014     Interp *iPtr = (Interp *) interp;
4015     Tcl_Obj *valuePtr;
4016     long i = 0; /* Initialized to avoid compiler warning. */
4017     int result;
4018    
4019     /*
4020     * Set stackPtr and stackTop from eePtr.
4021     */
4022    
4023     CACHE_STACK_INFO();
4024    
4025     /*
4026     * Pop the argument from the evaluation stack. Use the value
4027     * to reset the random number seed.
4028     */
4029    
4030     valuePtr = POP_OBJECT();
4031    
4032     if (VerifyExprObjType(interp, valuePtr) != TCL_OK) {
4033     result = TCL_ERROR;
4034     goto badValue;
4035     }
4036    
4037     if (valuePtr->typePtr == &tclIntType) {
4038     i = valuePtr->internalRep.longValue;
4039     } else {
4040     /*
4041     * At this point, the only other possible type is double
4042     */
4043     Tcl_ResetResult(interp);
4044     Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
4045     "can't use floating-point value as argument to srand",
4046     (char *) NULL);
4047     badValue:
4048     Tcl_DecrRefCount(valuePtr);
4049     DECACHE_STACK_INFO();
4050     return TCL_ERROR;
4051     }
4052    
4053     /*
4054     * Reset the seed.
4055     */
4056    
4057     iPtr->flags |= RAND_SEED_INITIALIZED;
4058     iPtr->randSeed = i;
4059    
4060     /*
4061     * To avoid duplicating the random number generation code we simply
4062     * clean up our state and call the real random number function. That
4063     * function will always succeed.
4064     */
4065    
4066     Tcl_DecrRefCount(valuePtr);
4067     DECACHE_STACK_INFO();
4068    
4069     ExprRandFunc(interp, eePtr, clientData);
4070     return TCL_OK;
4071     }
4072    
4073     /*
4074     *----------------------------------------------------------------------
4075     *
4076     * ExprCallMathFunc --
4077     *
4078     * This procedure is invoked to call a non-builtin math function
4079     * during the execution of an expression.
4080     *
4081     * Results:
4082     * TCL_OK is returned if all went well and the function's value
4083     * was computed successfully. If an error occurred, TCL_ERROR
4084     * is returned and an error message is left in the interpreter's
4085     * result. After a successful return this procedure pushes a Tcl object
4086     * holding the result.
4087     *
4088     * Side effects:
4089     * None, unless the called math function has side effects.
4090     *
4091     *----------------------------------------------------------------------
4092     */
4093    
4094     static int
4095     ExprCallMathFunc(interp, eePtr, objc, objv)
4096     Tcl_Interp *interp; /* The interpreter in which to execute the
4097     * function. */
4098     ExecEnv *eePtr; /* Points to the environment for executing
4099     * the function. */
4100     int objc; /* Number of arguments. The function name is
4101     * the 0-th argument. */
4102     Tcl_Obj **objv; /* The array of arguments. The function name
4103     * is objv[0]. */
4104     {
4105     Interp *iPtr = (Interp *) interp;
4106     Tcl_Obj **stackPtr; /* Cached evaluation stack base pointer. */
4107     register int stackTop; /* Cached top index of evaluation stack. */
4108     char *funcName;
4109     Tcl_HashEntry *hPtr;
4110     MathFunc *mathFuncPtr; /* Information about math function. */
4111     Tcl_Value args[MAX_MATH_ARGS]; /* Arguments for function call. */
4112     Tcl_Value funcResult; /* Result of function call as Tcl_Value. */
4113     register Tcl_Obj *valuePtr;
4114     long i;
4115     double d;
4116     int j, k, result;
4117     ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
4118    
4119     Tcl_ResetResult(interp);
4120    
4121     /*
4122     * Set stackPtr and stackTop from eePtr.
4123     */
4124    
4125     CACHE_STACK_INFO();
4126    
4127     /*
4128     * Look up the MathFunc record for the function.
4129     */
4130    
4131     funcName = Tcl_GetString(objv[0]);
4132     hPtr = Tcl_FindHashEntry(&iPtr->mathFuncTable, funcName);
4133     if (hPtr == NULL) {
4134     Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
4135     "unknown math function \"", funcName, "\"", (char *) NULL);
4136     result = TCL_ERROR;
4137     goto done;
4138     }
4139     mathFuncPtr = (MathFunc *) Tcl_GetHashValue(hPtr);
4140     if (mathFuncPtr->numArgs != (objc-1)) {
4141     panic("ExprCallMathFunc: expected number of args %d != actual number %d",
4142     mathFuncPtr->numArgs, objc);
4143     result = TCL_ERROR;
4144     goto done;
4145     }
4146    
4147     /*
4148     * Collect the arguments for the function, if there are any, into the
4149     * array "args". Note that args[0] will have the Tcl_Value that
4150     * corresponds to objv[1].
4151     */
4152    
4153     for (j = 1, k = 0; j < objc; j++, k++) {
4154     valuePtr = objv[j];
4155    
4156     if (VerifyExprObjType(interp, valuePtr) != TCL_OK) {
4157     result = TCL_ERROR;
4158     goto done;
4159     }
4160    
4161     /*
4162     * Copy the object's numeric value to the argument record,
4163     * converting it if necessary.
4164     */
4165    
4166     if (valuePtr->typePtr == &tclIntType) {
4167     i = valuePtr->internalRep.longValue;
4168     if (mathFuncPtr->argTypes[k] == TCL_DOUBLE) {
4169     args[k].type = TCL_DOUBLE;
4170     args[k].doubleValue = i;
4171     } else {
4172     args[k].type = TCL_INT;
4173     args[k].intValue = i;
4174     }
4175     } else {
4176     d = valuePtr->internalRep.doubleValue;
4177     if (mathFuncPtr->argTypes[k] == TCL_INT) {
4178     args[k].type = TCL_INT;
4179     args[k].intValue = (long) d;
4180     } else {
4181     args[k].type = TCL_DOUBLE;
4182     args[k].doubleValue = d;
4183     }
4184     }
4185     }
4186    
4187     /*
4188     * Invoke the function and copy its result back into valuePtr.
4189     */
4190    
4191     tsdPtr->mathInProgress++;
4192     result = (*mathFuncPtr->proc)(mathFuncPtr->clientData, interp, args,
4193     &funcResult);
4194     tsdPtr->mathInProgress--;
4195     if (result != TCL_OK) {
4196     goto done;
4197     }
4198    
4199     /*
4200     * Pop the objc top stack elements and decrement their ref counts.
4201     */
4202    
4203     i = (stackTop - (objc-1));
4204     while (i <= stackTop) {
4205     valuePtr = stackPtr[i];
4206     Tcl_DecrRefCount(valuePtr);
4207     i++;
4208     }
4209     stackTop -= objc;
4210    
4211     /*
4212     * Push the call's object result.
4213     */
4214    
4215     if (funcResult.type == TCL_INT) {
4216     PUSH_OBJECT(Tcl_NewLongObj(funcResult.intValue));
4217     } else {
4218     d = funcResult.doubleValue;
4219     if (IS_NAN(d) || IS_INF(d)) {
4220     TclExprFloatError(interp, d);
4221     result = TCL_ERROR;
4222     goto done;
4223     }
4224     PUSH_OBJECT(Tcl_NewDoubleObj(d));
4225     }
4226    
4227     /*
4228     * Reflect the change to stackTop back in eePtr.
4229     */
4230    
4231     done:
4232     DECACHE_STACK_INFO();
4233     return result;
4234     }
4235    
4236     /*
4237     *----------------------------------------------------------------------
4238     *
4239     * TclExprFloatError --
4240     *
4241     * This procedure is called when an error occurs during a
4242     * floating-point operation. It reads errno and sets
4243     * interp->objResultPtr accordingly.
4244     *
4245     * Results:
4246     * interp->objResultPtr is set to hold an error message.
4247     *
4248     * Side effects:
4249     * None.
4250     *
4251     *----------------------------------------------------------------------
4252     */
4253    
4254     void
4255     TclExprFloatError(interp, value)
4256     Tcl_Interp *interp; /* Where to store error message. */
4257     double value; /* Value returned after error; used to
4258     * distinguish underflows from overflows. */
4259     {
4260     char *s;
4261    
4262     Tcl_ResetResult(interp);
4263     if ((errno == EDOM) || (value != value)) {
4264     s = "domain error: argument not in valid range";
4265     Tcl_AppendToObj(Tcl_GetObjResult(interp), s, -1);
4266     Tcl_SetErrorCode(interp, "ARITH", "DOMAIN", s, (char *) NULL);
4267     } else if ((errno == ERANGE) || IS_INF(value)) {
4268     if (value == 0.0) {
4269     s = "floating-point value too small to represent";
4270     Tcl_AppendToObj(Tcl_GetObjResult(interp), s, -1);
4271     Tcl_SetErrorCode(interp, "ARITH", "UNDERFLOW", s, (char *) NULL);
4272     } else {
4273     s = "floating-point value too large to represent";
4274     Tcl_AppendToObj(Tcl_GetObjResult(interp), s, -1);
4275     Tcl_SetErrorCode(interp, "ARITH", "OVERFLOW", s, (char *) NULL);
4276     }
4277     } else {
4278     char msg[64 + TCL_INTEGER_SPACE];
4279    
4280     sprintf(msg, "unknown floating-point error, errno = %d", errno);
4281     Tcl_AppendToObj(Tcl_GetObjResult(interp), msg, -1);
4282     Tcl_SetErrorCode(interp, "ARITH", "UNKNOWN", msg, (char *) NULL);
4283     }
4284     }
4285    
4286     /*
4287     *----------------------------------------------------------------------
4288     *
4289     * TclMathInProgress --
4290     *
4291     * This procedure is called to find out if Tcl is doing math
4292     * in this thread.
4293     *
4294     * Results:
4295     * 0 or 1.
4296     *
4297     * Side effects:
4298     * None.
4299     *
4300     *----------------------------------------------------------------------
4301     */
4302    
4303     int
4304     TclMathInProgress()
4305     {
4306     ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
4307     return tsdPtr->mathInProgress;
4308     }
4309    
4310     #ifdef TCL_COMPILE_STATS
4311     /*
4312     *----------------------------------------------------------------------
4313     *
4314     * TclLog2 --
4315     *
4316     * Procedure used while collecting compilation statistics to determine
4317     * the log base 2 of an integer.
4318     *
4319     * Results:
4320     * Returns the log base 2 of the operand. If the argument is less
4321     * than or equal to zero, a zero is returned.
4322     *
4323     * Side effects:
4324     * None.
4325     *
4326     *----------------------------------------------------------------------
4327     */
4328    
4329     int
4330     TclLog2(value)
4331     register int value; /* The integer for which to compute the
4332     * log base 2. */
4333     {
4334     register int n = value;
4335     register int result = 0;
4336    
4337     while (n > 1) {
4338     n = n >> 1;
4339     result++;
4340     }
4341     return result;
4342     }
4343    
4344     /*
4345     *----------------------------------------------------------------------
4346     *
4347     * EvalStatsCmd --
4348     *
4349     * Implements the "evalstats" command that prints instruction execution
4350     * counts to stdout.
4351     *
4352     * Results:
4353     * Standard Tcl results.
4354     *
4355     * Side effects:
4356     * None.
4357     *
4358     *----------------------------------------------------------------------
4359     */
4360    
4361     static int
4362     EvalStatsCmd(unused, interp, argc, argv)
4363     ClientData unused; /* Unused. */
4364     Tcl_Interp *interp; /* The current interpreter. */
4365     int argc; /* The number of arguments. */
4366     char **argv; /* The argument strings. */
4367     {
4368     Interp *iPtr = (Interp *) interp;
4369     LiteralTable *globalTablePtr = &(iPtr->literalTable);
4370     ByteCodeStats *statsPtr = &(iPtr->stats);
4371     double totalCodeBytes, currentCodeBytes;
4372     double totalLiteralBytes, currentLiteralBytes;
4373     double objBytesIfUnshared, strBytesIfUnshared, sharingBytesSaved;
4374     double strBytesSharedMultX, strBytesSharedOnce;
4375     double numInstructions, currentHeaderBytes;
4376     long numCurrentByteCodes, numByteCodeLits;
4377     long refCountSum, literalMgmtBytes, sum;
4378     int numSharedMultX, numSharedOnce;
4379     int decadeHigh, minSizeDecade, maxSizeDecade, length, i;
4380     char *litTableStats;
4381     LiteralEntry *entryPtr;
4382    
4383     numInstructions = 0.0;
4384     for (i = 0; i < 256; i++) {
4385     if (statsPtr->instructionCount[i] != 0) {
4386     numInstructions += statsPtr->instructionCount[i];
4387     }
4388     }
4389    
4390     totalLiteralBytes = sizeof(LiteralTable)
4391     + iPtr->literalTable.numBuckets * sizeof(LiteralEntry *)
4392     + (statsPtr->numLiteralsCreated * sizeof(LiteralEntry))
4393     + (statsPtr->numLiteralsCreated * sizeof(Tcl_Obj))
4394     + statsPtr->totalLitStringBytes;
4395     totalCodeBytes = statsPtr->totalByteCodeBytes + totalLiteralBytes;
4396    
4397     numCurrentByteCodes =
4398     statsPtr->numCompilations - statsPtr->numByteCodesFreed;
4399     currentHeaderBytes = numCurrentByteCodes
4400     * (sizeof(ByteCode) - (sizeof(size_t) + sizeof(Tcl_Time)));
4401     literalMgmtBytes = sizeof(LiteralTable)
4402     + (iPtr->literalTable.numBuckets * sizeof(LiteralEntry *))
4403     + (iPtr->literalTable.numEntries * sizeof(LiteralEntry));
4404     currentLiteralBytes = literalMgmtBytes
4405     + iPtr->literalTable.numEntries * sizeof(Tcl_Obj)
4406     + statsPtr->currentLitStringBytes;
4407     currentCodeBytes = statsPtr->currentByteCodeBytes + currentLiteralBytes;
4408    
4409     /*
4410     * Summary statistics, total and current source and ByteCode sizes.
4411     */
4412    
4413     fprintf(stdout, "\n----------------------------------------------------------------\n");
4414     fprintf(stdout,
4415     "Compilation and execution statistics for interpreter 0x%x\n",
4416     (unsigned int) iPtr);
4417    
4418     fprintf(stdout, "\nNumber ByteCodes executed %ld\n",
4419     statsPtr->numExecutions);
4420     fprintf(stdout, "Number ByteCodes compiled %ld\n",
4421     statsPtr->numCompilations);
4422     fprintf(stdout, " Mean executions/compile %.1f\n",
4423     ((float)statsPtr->numExecutions) / ((float)statsPtr->numCompilations));
4424    
4425     fprintf(stdout, "\nInstructions executed %.0f\n",
4426     numInstructions);
4427     fprintf(stdout, " Mean inst/compile %.0f\n",
4428     numInstructions / statsPtr->numCompilations);
4429     fprintf(stdout, " Mean inst/execution %.0f\n",
4430     numInstructions / statsPtr->numExecutions);
4431    
4432     fprintf(stdout, "\nTotal ByteCodes %ld\n",
4433     statsPtr->numCompilations);
4434     fprintf(stdout, " Source bytes %.6g\n",
4435     statsPtr->totalSrcBytes);
4436     fprintf(stdout, " Code bytes %.6g\n",
4437     totalCodeBytes);
4438     fprintf(stdout, " ByteCode bytes %.6g\n",
4439     statsPtr->totalByteCodeBytes);
4440     fprintf(stdout, " Literal bytes %.6g\n",
4441     totalLiteralBytes);
4442     fprintf(stdout, " table %d + bkts %d + entries %ld + objects %ld + strings %.6g\n",
4443     sizeof(LiteralTable),
4444     iPtr->literalTable.numBuckets * sizeof(LiteralEntry *),
4445     statsPtr->numLiteralsCreated * sizeof(LiteralEntry),
4446     statsPtr->numLiteralsCreated * sizeof(Tcl_Obj),
4447     statsPtr->totalLitStringBytes);
4448     fprintf(stdout, " Mean code/compile %.1f\n",
4449     totalCodeBytes / statsPtr->numCompilations);
4450     fprintf(stdout, " Mean code/source %.1f\n",
4451     totalCodeBytes / statsPtr->totalSrcBytes);
4452    
4453     fprintf(stdout, "\nCurrent ByteCodes %ld\n",
4454     numCurrentByteCodes);
4455     fprintf(stdout, " Source bytes %.6g\n",
4456     statsPtr->currentSrcBytes);
4457     fprintf(stdout, " Code bytes %.6g\n",
4458     currentCodeBytes);
4459     fprintf(stdout, " ByteCode bytes %.6g\n",
4460     statsPtr->currentByteCodeBytes);
4461     fprintf(stdout, " Literal bytes %.6g\n",
4462     currentLiteralBytes);
4463     fprintf(stdout, " table %d + bkts %d + entries %d + objects %d + strings %.6g\n",
4464     sizeof(LiteralTable),
4465     iPtr->literalTable.numBuckets * sizeof(LiteralEntry *),
4466     iPtr->literalTable.numEntries * sizeof(LiteralEntry),
4467     iPtr->literalTable.numEntries * sizeof(Tcl_Obj),
4468     statsPtr->currentLitStringBytes);
4469     fprintf(stdout, " Mean code/source %.1f\n",
4470     currentCodeBytes / statsPtr->currentSrcBytes);
4471     fprintf(stdout, " Code + source bytes %.6g (%0.1f mean code/src)\n",
4472     (currentCodeBytes + statsPtr->currentSrcBytes),
4473     (currentCodeBytes / statsPtr->currentSrcBytes) + 1.0);
4474    
4475     /*
4476     * Literal table statistics.
4477     */
4478    
4479     numByteCodeLits = 0;
4480     refCountSum = 0;
4481     numSharedMultX = 0;
4482     numSharedOnce = 0;
4483     objBytesIfUnshared = 0.0;
4484     strBytesIfUnshared = 0.0;
4485     strBytesSharedMultX = 0.0;
4486     strBytesSharedOnce = 0.0;
4487     for (i = 0; i < globalTablePtr->numBuckets; i++) {
4488     for (entryPtr = globalTablePtr->buckets[i]; entryPtr != NULL;
4489     entryPtr = entryPtr->nextPtr) {
4490     if (entryPtr->objPtr->typePtr == &tclByteCodeType) {
4491     numByteCodeLits++;
4492     }
4493     (void) Tcl_GetStringFromObj(entryPtr->objPtr, &length);
4494     refCountSum += entryPtr->refCount;
4495     objBytesIfUnshared += (entryPtr->refCount * sizeof(Tcl_Obj));
4496     strBytesIfUnshared += (entryPtr->refCount * (length+1));
4497     if (entryPtr->refCount > 1) {
4498     numSharedMultX++;
4499     strBytesSharedMultX += (length+1);
4500     } else {
4501     numSharedOnce++;
4502     strBytesSharedOnce += (length+1);
4503     }
4504     }
4505     }
4506     sharingBytesSaved = (objBytesIfUnshared + strBytesIfUnshared)
4507     - currentLiteralBytes;
4508    
4509     fprintf(stdout, "\nTotal objects (all interps) %ld\n",
4510     tclObjsAlloced);
4511     fprintf(stdout, "Current objects %ld\n",
4512     (tclObjsAlloced - tclObjsFreed));
4513     fprintf(stdout, "Total literal objects %ld\n",
4514     statsPtr->numLiteralsCreated);
4515    
4516     fprintf(stdout, "\nCurrent literal objects %d (%0.1f%% of current objects)\n",
4517     globalTablePtr->numEntries,
4518     (globalTablePtr->numEntries * 100.0) / (tclObjsAlloced-tclObjsFreed));
4519     fprintf(stdout, " ByteCode literals %ld (%0.1f%% of current literals)\n",
4520     numByteCodeLits,
4521     (numByteCodeLits * 100.0) / globalTablePtr->numEntries);
4522     fprintf(stdout, " Literals reused > 1x %d\n",
4523     numSharedMultX);
4524     fprintf(stdout, " Mean reference count %.2f\n",
4525     ((double) refCountSum) / globalTablePtr->numEntries);
4526     fprintf(stdout, " Mean len, str reused >1x %.2f\n",
4527     (numSharedMultX? (strBytesSharedMultX/numSharedMultX) : 0.0));
4528     fprintf(stdout, " Mean len, str used 1x %.2f\n",
4529     (numSharedOnce? (strBytesSharedOnce/numSharedOnce) : 0.0));
4530     fprintf(stdout, " Total sharing savings %.6g (%0.1f%% of bytes if no sharing)\n",
4531     sharingBytesSaved,
4532     (sharingBytesSaved * 100.0) / (objBytesIfUnshared + strBytesIfUnshared));
4533     fprintf(stdout, " Bytes with sharing %.6g\n",
4534     currentLiteralBytes);
4535     fprintf(stdout, " table %d + bkts %d + entries %d + objects %d + strings %.6g\n",
4536     sizeof(LiteralTable),
4537     iPtr->literalTable.numBuckets * sizeof(LiteralEntry *),
4538     iPtr->literalTable.numEntries * sizeof(LiteralEntry),
4539     iPtr->literalTable.numEntries * sizeof(Tcl_Obj),
4540     statsPtr->currentLitStringBytes);
4541     fprintf(stdout, " Bytes if no sharing %.6g = objects %.6g + strings %.6g\n",
4542     (objBytesIfUnshared + strBytesIfUnshared),
4543     objBytesIfUnshared, strBytesIfUnshared);
4544     fprintf(stdout, " String sharing savings %.6g = unshared %.6g - shared %.6g\n",
4545     (strBytesIfUnshared - statsPtr->currentLitStringBytes),
4546     strBytesIfUnshared, statsPtr->currentLitStringBytes);
4547     fprintf(stdout, " Literal mgmt overhead %ld (%0.1f%% of bytes with sharing)\n",
4548     literalMgmtBytes,
4549     (literalMgmtBytes * 100.0) / currentLiteralBytes);
4550     fprintf(stdout, " table %d + buckets %d + entries %d\n",
4551     sizeof(LiteralTable),
4552     iPtr->literalTable.numBuckets * sizeof(LiteralEntry *),
4553     iPtr->literalTable.numEntries * sizeof(LiteralEntry));
4554    
4555     /*
4556     * Breakdown of current ByteCode space requirements.
4557     */
4558    
4559     fprintf(stdout, "\nBreakdown of current ByteCode requirements:\n");
4560     fprintf(stdout, " Bytes Pct of Avg per\n");
4561     fprintf(stdout, " total ByteCode\n");
4562     fprintf(stdout, "Total %12.6g 100.00%% %8.1f\n",
4563     statsPtr->currentByteCodeBytes,
4564     statsPtr->currentByteCodeBytes / numCurrentByteCodes);
4565     fprintf(stdout, "Header %12.6g %8.1f%% %8.1f\n",
4566     currentHeaderBytes,
4567     ((currentHeaderBytes * 100.0) / statsPtr->currentByteCodeBytes),
4568     currentHeaderBytes / numCurrentByteCodes);
4569     fprintf(stdout, "Instructions %12.6g %8.1f%% %8.1f\n",
4570     statsPtr->currentInstBytes,
4571     ((statsPtr->currentInstBytes * 100.0) / statsPtr->currentByteCodeBytes),
4572     statsPtr->currentInstBytes / numCurrentByteCodes);
4573     fprintf(stdout, "Literal ptr array %12.6g %8.1f%% %8.1f\n",
4574     statsPtr->currentLitBytes,
4575     ((statsPtr->currentLitBytes * 100.0) / statsPtr->currentByteCodeBytes),
4576     statsPtr->currentLitBytes / numCurrentByteCodes);
4577     fprintf(stdout, "Exception table %12.6g %8.1f%% %8.1f\n",
4578     statsPtr->currentExceptBytes,
4579     ((statsPtr->currentExceptBytes * 100.0) / statsPtr->currentByteCodeBytes),
4580     statsPtr->currentExceptBytes / numCurrentByteCodes);
4581     fprintf(stdout, "Auxiliary data %12.6g %8.1f%% %8.1f\n",
4582     statsPtr->currentAuxBytes,
4583     ((statsPtr->currentAuxBytes * 100.0) / statsPtr->currentByteCodeBytes),
4584     statsPtr->currentAuxBytes / numCurrentByteCodes);
4585     fprintf(stdout, "Command map %12.6g %8.1f%% %8.1f\n",
4586     statsPtr->currentCmdMapBytes,
4587     ((statsPtr->currentCmdMapBytes * 100.0) / statsPtr->currentByteCodeBytes),
4588     statsPtr->currentCmdMapBytes / numCurrentByteCodes);
4589    
4590     /*
4591     * Detailed literal statistics.
4592     */
4593    
4594     fprintf(stdout, "\nLiteral string sizes:\n");
4595     fprintf(stdout, " Up to length Percentage\n");
4596     maxSizeDecade = 0;
4597     for (i = 31; i >= 0; i--) {
4598     if (statsPtr->literalCount[i] > 0) {
4599     maxSizeDecade = i;
4600     break;
4601     }
4602     }
4603     sum = 0;
4604     for (i = 0; i <= maxSizeDecade; i++) {
4605     decadeHigh = (1 << (i+1)) - 1;
4606     sum += statsPtr->literalCount[i];
4607     fprintf(stdout, " %10d %8.0f%%\n",
4608     decadeHigh, (sum * 100.0) / statsPtr->numLiteralsCreated);
4609     }
4610    
4611     litTableStats = TclLiteralStats(globalTablePtr);
4612     fprintf(stdout, "\nCurrent literal table statistics:\n%s\n",
4613     litTableStats);
4614     ckfree((char *) litTableStats);
4615    
4616     /*
4617     * Source and ByteCode size distributions.
4618     */
4619    
4620     fprintf(stdout, "\nSource sizes:\n");
4621     fprintf(stdout, " Up to size Percentage\n");
4622     minSizeDecade = maxSizeDecade = 0;
4623     for (i = 0; i < 31; i++) {
4624     if (statsPtr->srcCount[i] > 0) {
4625     minSizeDecade = i;
4626     break;
4627     }
4628     }
4629     for (i = 31; i >= 0; i--) {
4630     if (statsPtr->srcCount[i] > 0) {
4631     maxSizeDecade = i;
4632     break;
4633     }
4634     }
4635     sum = 0;
4636     for (i = minSizeDecade; i <= maxSizeDecade; i++) {
4637     decadeHigh = (1 << (i+1)) - 1;
4638     sum += statsPtr->srcCount[i];
4639     fprintf(stdout, " %10d %8.0f%%\n",
4640     decadeHigh, (sum * 100.0) / statsPtr->numCompilations);
4641     }
4642    
4643     fprintf(stdout, "\nByteCode sizes:\n");
4644     fprintf(stdout, " Up to size Percentage\n");
4645     minSizeDecade = maxSizeDecade = 0;
4646     for (i = 0; i < 31; i++) {
4647     if (statsPtr->byteCodeCount[i] > 0) {
4648     minSizeDecade = i;
4649     break;
4650     }
4651     }
4652     for (i = 31; i >= 0; i--) {
4653     if (statsPtr->byteCodeCount[i] > 0) {
4654     maxSizeDecade = i;
4655     break;
4656     }
4657     }
4658     sum = 0;
4659     for (i = minSizeDecade; i <= maxSizeDecade; i++) {
4660     decadeHigh = (1 << (i+1)) - 1;
4661     sum += statsPtr->byteCodeCount[i];
4662     fprintf(stdout, " %10d %8.0f%%\n",
4663     decadeHigh, (sum * 100.0) / statsPtr->numCompilations);
4664     }
4665    
4666     fprintf(stdout, "\nByteCode longevity (excludes current ByteCodes):\n");
4667     fprintf(stdout, " Up to ms Percentage\n");
4668     minSizeDecade = maxSizeDecade = 0;
4669     for (i = 0; i < 31; i++) {
4670     if (statsPtr->lifetimeCount[i] > 0) {
4671     minSizeDecade = i;
4672     break;
4673     }
4674     }
4675     for (i = 31; i >= 0; i--) {
4676     if (statsPtr->lifetimeCount[i] > 0) {
4677     maxSizeDecade = i;
4678     break;
4679     }
4680     }
4681     sum = 0;
4682     for (i = minSizeDecade; i <= maxSizeDecade; i++) {
4683     decadeHigh = (1 << (i+1)) - 1;
4684     sum += statsPtr->lifetimeCount[i];
4685     fprintf(stdout, " %12.3f %8.0f%%\n",
4686     decadeHigh / 1000.0,
4687     (sum * 100.0) / statsPtr->numByteCodesFreed);
4688     }
4689    
4690     /*
4691     * Instruction counts.
4692     */
4693    
4694     fprintf(stdout, "\nInstruction counts:\n");
4695     for (i = 0; i <= LAST_INST_OPCODE; i++) {
4696     if (statsPtr->instructionCount[i]) {
4697     fprintf(stdout, "%20s %8ld %6.1f%%\n",
4698     instructionTable[i].name,
4699     statsPtr->instructionCount[i],
4700     (statsPtr->instructionCount[i]*100.0) / numInstructions);
4701     }
4702     }
4703    
4704     fprintf(stdout, "\nInstructions NEVER executed:\n");
4705     for (i = 0; i <= LAST_INST_OPCODE; i++) {
4706     if (statsPtr->instructionCount[i] == 0) {
4707     fprintf(stdout, "%20s\n",
4708     instructionTable[i].name);
4709     }
4710     }
4711    
4712     #ifdef TCL_MEM_DEBUG
4713     fprintf(stdout, "\nHeap Statistics:\n");
4714     TclDumpMemoryInfo(stdout);
4715     #endif
4716     fprintf(stdout, "\n----------------------------------------------------------------\n");
4717     return TCL_OK;
4718     }
4719     #endif /* TCL_COMPILE_STATS */
4720    
4721     /*
4722     *----------------------------------------------------------------------
4723     *
4724     * Tcl_GetCommandFromObj --
4725     *
4726     * Returns the command specified by the name in a Tcl_Obj.
4727     *
4728     * Results:
4729     * Returns a token for the command if it is found. Otherwise, if it
4730     * can't be found or there is an error, returns NULL.
4731     *
4732     * Side effects:
4733     * May update the internal representation for the object, caching
4734     * the command reference so that the next time this procedure is
4735     * called with the same object, the command can be found quickly.
4736     *
4737     *----------------------------------------------------------------------
4738     */
4739    
4740     Tcl_Command
4741     Tcl_GetCommandFromObj(interp, objPtr)
4742     Tcl_Interp *interp; /* The interpreter in which to resolve the
4743     * command and to report errors. */
4744     register Tcl_Obj *objPtr; /* The object containing the command's
4745     * name. If the name starts with "::", will
4746     * be looked up in global namespace. Else,
4747     * looked up first in the current namespace
4748     * if contextNsPtr is NULL, then in global
4749     * namespace. */
4750     {
4751     Interp *iPtr = (Interp *) interp;
4752     register ResolvedCmdName *resPtr;
4753     register Command *cmdPtr;
4754     Namespace *currNsPtr;
4755     int result;
4756    
4757     /*
4758     * Get the internal representation, converting to a command type if
4759     * needed. The internal representation is a ResolvedCmdName that points
4760     * to the actual command.
4761     */
4762    
4763     if (objPtr->typePtr != &tclCmdNameType) {
4764     result = tclCmdNameType.setFromAnyProc(interp, objPtr);
4765     if (result != TCL_OK) {
4766     return (Tcl_Command) NULL;
4767     }
4768     }
4769     resPtr = (ResolvedCmdName *) objPtr->internalRep.otherValuePtr;
4770    
4771     /*
4772     * Get the current namespace.
4773     */
4774    
4775     if (iPtr->varFramePtr != NULL) {
4776     currNsPtr = iPtr->varFramePtr->nsPtr;
4777     } else {
4778     currNsPtr = iPtr->globalNsPtr;
4779     }
4780    
4781     /*
4782     * Check the context namespace and the namespace epoch of the resolved
4783     * symbol to make sure that it is fresh. If not, then force another
4784     * conversion to the command type, to discard the old rep and create a
4785     * new one. Note that we verify that the namespace id of the context
4786     * namespace is the same as the one we cached; this insures that the
4787     * namespace wasn't deleted and a new one created at the same address
4788     * with the same command epoch.
4789     */
4790    
4791     cmdPtr = NULL;
4792     if ((resPtr != NULL)
4793     && (resPtr->refNsPtr == currNsPtr)
4794     && (resPtr->refNsId == currNsPtr->nsId)
4795     && (resPtr->refNsCmdEpoch == currNsPtr->cmdRefEpoch)) {
4796     cmdPtr = resPtr->cmdPtr;
4797     if (cmdPtr->cmdEpoch != resPtr->cmdEpoch) {
4798     cmdPtr = NULL;
4799     }
4800     }
4801    
4802     if (cmdPtr == NULL) {
4803     result = tclCmdNameType.setFromAnyProc(interp, objPtr);
4804     if (result != TCL_OK) {
4805     return (Tcl_Command) NULL;
4806     }
4807     resPtr = (ResolvedCmdName *) objPtr->internalRep.otherValuePtr;
4808     if (resPtr != NULL) {
4809     cmdPtr = resPtr->cmdPtr;
4810     }
4811     }
4812     return (Tcl_Command) cmdPtr;
4813     }
4814    
4815     /*
4816     *----------------------------------------------------------------------
4817     *
4818     * TclSetCmdNameObj --
4819     *
4820     * Modify an object to be an CmdName object that refers to the argument
4821     * Command structure.
4822     *
4823     * Results:
4824     * None.
4825     *
4826     * Side effects:
4827     * The object's old internal rep is freed. It's string rep is not
4828     * changed. The refcount in the Command structure is incremented to
4829     * keep it from being freed if the command is later deleted until
4830     * TclExecuteByteCode has a chance to recognize that it was deleted.
4831     *
4832     *----------------------------------------------------------------------
4833     */
4834    
4835     void
4836     TclSetCmdNameObj(interp, objPtr, cmdPtr)
4837     Tcl_Interp *interp; /* Points to interpreter containing command
4838     * that should be cached in objPtr. */
4839     register Tcl_Obj *objPtr; /* Points to Tcl object to be changed to
4840     * a CmdName object. */
4841     Command *cmdPtr; /* Points to Command structure that the
4842     * CmdName object should refer to. */
4843     {
4844     Interp *iPtr = (Interp *) interp;
4845     register ResolvedCmdName *resPtr;
4846     Tcl_ObjType *oldTypePtr = objPtr->typePtr;
4847     register Namespace *currNsPtr;
4848    
4849     if (oldTypePtr == &tclCmdNameType) {
4850     return;
4851     }
4852    
4853     /*
4854     * Get the current namespace.
4855     */
4856    
4857     if (iPtr->varFramePtr != NULL) {
4858     currNsPtr = iPtr->varFramePtr->nsPtr;
4859     } else {
4860     currNsPtr = iPtr->globalNsPtr;
4861     }
4862    
4863     cmdPtr->refCount++;
4864     resPtr = (ResolvedCmdName *) ckalloc(sizeof(ResolvedCmdName));
4865     resPtr->cmdPtr = cmdPtr;
4866     resPtr->refNsPtr = currNsPtr;
4867     resPtr->refNsId = currNsPtr->nsId;
4868     resPtr->refNsCmdEpoch = currNsPtr->cmdRefEpoch;
4869     resPtr->cmdEpoch = cmdPtr->cmdEpoch;
4870     resPtr->refCount = 1;
4871    
4872     if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) {
4873     oldTypePtr->freeIntRepProc(objPtr);
4874     }
4875     objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) resPtr;
4876     objPtr->internalRep.twoPtrValue.ptr2 = NULL;
4877     objPtr->typePtr = &tclCmdNameType;
4878     }
4879    
4880     /*
4881     *----------------------------------------------------------------------
4882     *
4883     * FreeCmdNameInternalRep --
4884     *
4885     * Frees the resources associated with a cmdName object's internal
4886     * representation.
4887     *
4888     * Results:
4889     * None.
4890     *
4891     * Side effects:
4892     * Decrements the ref count of any cached ResolvedCmdName structure
4893     * pointed to by the cmdName's internal representation. If this is
4894     * the last use of the ResolvedCmdName, it is freed. This in turn
4895     * decrements the ref count of the Command structure pointed to by
4896     * the ResolvedSymbol, which may free the Command structure.
4897     *
4898     *----------------------------------------------------------------------
4899     */
4900    
4901     static void
4902     FreeCmdNameInternalRep(objPtr)
4903     register Tcl_Obj *objPtr; /* CmdName object with internal
4904     * representation to free. */
4905     {
4906     register ResolvedCmdName *resPtr =
4907     (ResolvedCmdName *) objPtr->internalRep.otherValuePtr;
4908    
4909     if (resPtr != NULL) {
4910     /*
4911     * Decrement the reference count of the ResolvedCmdName structure.
4912     * If there are no more uses, free the ResolvedCmdName structure.
4913     */
4914    
4915     resPtr->refCount--;
4916     if (resPtr->refCount == 0) {
4917     /*
4918     * Now free the cached command, unless it is still in its
4919     * hash table or if there are other references to it
4920     * from other cmdName objects.
4921     */
4922    
4923     Command *cmdPtr = resPtr->cmdPtr;
4924     TclCleanupCommand(cmdPtr);
4925     ckfree((char *) resPtr);
4926     }
4927     }
4928     }
4929    
4930     /*
4931     *----------------------------------------------------------------------
4932     *
4933     * DupCmdNameInternalRep --
4934     *
4935     * Initialize the internal representation of an cmdName Tcl_Obj to a
4936     * copy of the internal representation of an existing cmdName object.
4937     *
4938     * Results:
4939     * None.
4940     *
4941     * Side effects:
4942     * "copyPtr"s internal rep is set to point to the ResolvedCmdName
4943     * structure corresponding to "srcPtr"s internal rep. Increments the
4944     * ref count of the ResolvedCmdName structure pointed to by the
4945     * cmdName's internal representation.
4946     *
4947     *----------------------------------------------------------------------
4948     */
4949    
4950     static void
4951     DupCmdNameInternalRep(srcPtr, copyPtr)
4952     Tcl_Obj *srcPtr; /* Object with internal rep to copy. */
4953     register Tcl_Obj *copyPtr; /* Object with internal rep to set. */
4954     {
4955     register ResolvedCmdName *resPtr =
4956     (ResolvedCmdName *) srcPtr->internalRep.otherValuePtr;
4957    
4958     copyPtr->internalRep.twoPtrValue.ptr1 = (VOID *) resPtr;
4959     copyPtr->internalRep.twoPtrValue.ptr2 = NULL;
4960     if (resPtr != NULL) {
4961     resPtr->refCount++;
4962     }
4963     copyPtr->typePtr = &tclCmdNameType;
4964     }
4965    
4966     /*
4967     *----------------------------------------------------------------------
4968     *
4969     * SetCmdNameFromAny --
4970     *
4971     * Generate an cmdName internal form for the Tcl object "objPtr".
4972     *
4973     * Results:
4974     * The return value is a standard Tcl result. The conversion always
4975     * succeeds and TCL_OK is returned.
4976     *
4977     * Side effects:
4978     * A pointer to a ResolvedCmdName structure that holds a cached pointer
4979     * to the command with a name that matches objPtr's string rep is
4980     * stored as objPtr's internal representation. This ResolvedCmdName
4981     * pointer will be NULL if no matching command was found. The ref count
4982     * of the cached Command's structure (if any) is also incremented.
4983     *
4984     *----------------------------------------------------------------------
4985     */
4986    
4987     static int
4988     SetCmdNameFromAny(interp, objPtr)
4989     Tcl_Interp *interp; /* Used for error reporting if not NULL. */
4990     register Tcl_Obj *objPtr; /* The object to convert. */
4991     {
4992     Interp *iPtr = (Interp *) interp;
4993     char *name;
4994     Tcl_Command cmd;
4995     register Command *cmdPtr;
4996     Namespace *currNsPtr;
4997     register ResolvedCmdName *resPtr;
4998    
4999     /*
5000     * Get "objPtr"s string representation. Make it up-to-date if necessary.
5001     */
5002    
5003     name = objPtr->bytes;
5004     if (name == NULL) {
5005     name = Tcl_GetString(objPtr);
5006     }
5007    
5008     /*
5009     * Find the Command structure, if any, that describes the command called
5010     * "name". Build a ResolvedCmdName that holds a cached pointer to this
5011     * Command, and bump the reference count in the referenced Command
5012     * structure. A Command structure will not be deleted as long as it is
5013     * referenced from a CmdName object.
5014     */
5015    
5016     cmd = Tcl_FindCommand(interp, name, (Tcl_Namespace *) NULL,
5017     /*flags*/ 0);
5018     cmdPtr = (Command *) cmd;
5019     if (cmdPtr != NULL) {
5020     /*
5021     * Get the current namespace.
5022     */
5023    
5024     if (iPtr->varFramePtr != NULL) {
5025     currNsPtr = iPtr->varFramePtr->nsPtr;
5026     } else {
5027     currNsPtr = iPtr->globalNsPtr;
5028     }
5029    
5030     cmdPtr->refCount++;
5031     resPtr = (ResolvedCmdName *) ckalloc(sizeof(ResolvedCmdName));
5032     resPtr->cmdPtr = cmdPtr;
5033     resPtr->refNsPtr = currNsPtr;
5034     resPtr->refNsId = currNsPtr->nsId;
5035     resPtr->refNsCmdEpoch = currNsPtr->cmdRefEpoch;
5036     resPtr->cmdEpoch = cmdPtr->cmdEpoch;
5037     resPtr->refCount = 1;
5038     } else {
5039     resPtr = NULL; /* no command named "name" was found */
5040     }
5041    
5042     /*
5043     * Free the old internalRep before setting the new one. We do this as
5044     * late as possible to allow the conversion code, in particular
5045     * GetStringFromObj, to use that old internalRep. If no Command
5046     * structure was found, leave NULL as the cached value.
5047     */
5048    
5049     if ((objPtr->typePtr != NULL)
5050     && (objPtr->typePtr->freeIntRepProc != NULL)) {
5051     objPtr->typePtr->freeIntRepProc(objPtr);
5052     }
5053    
5054     objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) resPtr;
5055     objPtr->internalRep.twoPtrValue.ptr2 = NULL;
5056     objPtr->typePtr = &tclCmdNameType;
5057     return TCL_OK;
5058     }
5059    
5060     #ifdef TCL_COMPILE_DEBUG
5061     /*
5062     *----------------------------------------------------------------------
5063     *
5064     * StringForResultCode --
5065     *
5066     * Procedure that returns a human-readable string representing a
5067     * Tcl result code such as TCL_ERROR.
5068     *
5069     * Results:
5070     * If the result code is one of the standard Tcl return codes, the
5071     * result is a string representing that code such as "TCL_ERROR".
5072     * Otherwise, the result string is that code formatted as a
5073     * sequence of decimal digit characters. Note that the resulting
5074     * string must not be modified by the caller.
5075     *
5076     * Side effects:
5077     * None.
5078     *
5079     *----------------------------------------------------------------------
5080     */
5081    
5082     static char *
5083     StringForResultCode(result)
5084     int result; /* The Tcl result code for which to
5085     * generate a string. */
5086     {
5087     static char buf[TCL_INTEGER_SPACE];
5088    
5089     if ((result >= TCL_OK) && (result <= TCL_CONTINUE)) {
5090     return resultStrings[result];
5091     }
5092     TclFormatInt(buf, result);
5093     return buf;
5094     }
5095     #endif /* TCL_COMPILE_DEBUG */
5096    
5097     /* End of tclexecute.c */

Properties

Name Value
svn:eol-style native
svn:keywords Header

dashley@gmail.com
ViewVC Help
Powered by ViewVC 1.1.25