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

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 64 - (hide annotations) (download)
Sun Oct 30 04:21:11 2016 UTC (8 years ago) by dashley
File MIME type: text/plain
File size: 156562 byte(s)
Adjust line endings to Windows style.
Set properties to expand the "Header" keyword.
Change header and footer.
1 dashley 64 /* $Header$ */
2 dashley 25 /*
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();