/[dtapublic]/sf_code/esrgpcpj/shared/tcl_base/tclexecute.c
ViewVC logotype

Annotation of /sf_code/esrgpcpj/shared/tcl_base/tclexecute.c

Parent Directory Parent Directory | Revision Log Revision Log

Revision 25 - (hide annotations) (download)
Sat Oct 8 06:43:03 2016 UTC (8 years, 2 months ago) by dashley
File MIME type: text/plain
File size: 156893 byte(s) 
Initial commit.
1 dashley 25 /* $Header: /cvsroot/esrg/sfesrg/esrgpcpj/shared/tcl_base/tclexecute.c,v 1.1.1.1 2001/06/13 04:38:49 dtashley Exp $ */
2    
3     /*
4     * tclExecute.c --
5     *
6     * This file contains procedures that execute byte-compiled Tcl
7     * commands.
8     *
9     * Copyright (c) 1996-1997 Sun Microsystems, Inc.
10     *
11     * See the file "license.terms" for information on usage and redistribution
12     * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
13     *
14     * RCS: @(#) $Id: tclexecute.c,v 1.1.1.1 2001/06/13 04:38:49 dtashley Exp $
15     */
16    
17     #include "tclInt.h"
18     #include "tclCompile.h"
19    
20     #ifdef NO_FLOAT_H
21     # include "../compat/float.h"
22     #else
23     # include <float.h>
24     #endif
25     #ifndef TCL_NO_MATH
26     #include "tclMath.h"
27     #endif
28    
29     /*
30     * The stuff below is a bit of a hack so that this file can be used
31     * in environments that include no UNIX, i.e. no errno. Just define
32     * errno here.
33     */
34    
35     #ifndef TCL_GENERIC_ONLY
36     #include "tclPort.h"
37     #else
38     #define NO_ERRNO_H
39     #endif
40    
41     #ifdef NO_ERRNO_H
42     int errno;
43     #define EDOM 33
44     #define ERANGE 34
45     #endif
46    
47     /*
48     * Boolean flag indicating whether the Tcl bytecode interpreter has been
49     * initialized.
50     */
51    
52     static int execInitialized = 0;
53     TCL_DECLARE_MUTEX(execMutex)
54    
55     /*
56     * Variable that controls whether execution tracing is enabled and, if so,
57     * what level of tracing is desired:
58     * 0: no execution tracing
59     * 1: trace invocations of Tcl procs only
60     * 2: trace invocations of all (not compiled away) commands
61     * 3: display each instruction executed
62     * This variable is linked to the Tcl variable "tcl_traceExec".
63     */
64    
65     int tclTraceExec = 0;
66    
67     typedef struct ThreadSpecificData {
68     /*
69     * The following global variable is use to signal matherr that Tcl
70     * is responsible for the arithmetic, so errors can be handled in a
71     * fashion appropriate for Tcl. Zero means no Tcl math is in
72     * progress; non-zero means Tcl is doing math.
73     */
74    
75     int mathInProgress;
76    
77     } ThreadSpecificData;
78    
79     static Tcl_ThreadDataKey dataKey;
80    
81     /*
82     * The variable below serves no useful purpose except to generate
83     * a reference to matherr, so that the Tcl version of matherr is
84     * linked in rather than the system version. Without this reference
85     * the need for matherr won't be discovered during linking until after
86     * libtcl.a has been processed, so Tcl's version won't be used.
87     */
88    
89     #ifdef NEED_MATHERR
90     extern int matherr();
91     int (*tclMatherrPtr)() = matherr;
92     #endif
93    
94     /*
95     * Mapping from expression instruction opcodes to strings; used for error
96     * messages. Note that these entries must match the order and number of the
97     * expression opcodes (e.g., INST_LOR) in tclCompile.h.
98     */
99    
100     static char *operatorStrings[] = {
101     "||", "&&", "|", "^", "&", "==", "!=", "<", ">", "<=", ">=", "<<", ">>",
102     "+", "-", "*", "/", "%", "+", "-", "~", "!",
103     "BUILTIN FUNCTION", "FUNCTION"
104     };
105    
106     /*
107     * Mapping from Tcl result codes to strings; used for error and debugging
108     * messages.
109     */
110    
111     #ifdef TCL_COMPILE_DEBUG
112     static char *resultStrings[] = {
113     "TCL_OK", "TCL_ERROR", "TCL_RETURN", "TCL_BREAK", "TCL_CONTINUE"
114     };
115     #endif
116    
117     /*
118     * Macros for testing floating-point values for certain special cases. Test
119     * for not-a-number by comparing a value against itself; test for infinity
120     * by comparing against the largest floating-point value.
121     */
122    
123     #define IS_NAN(v) ((v) != (v))
124     #ifdef DBL_MAX
125     # define IS_INF(v) (((v) > DBL_MAX) || ((v) < -DBL_MAX))
126     #else
127     # define IS_INF(v) 0
128     #endif
129    
130     /*
131     * Macro to adjust the program counter and restart the instruction execution
132     * loop after each instruction is executed.
133     */
134    
135     #define ADJUST_PC(instBytes) \
136     pc += (instBytes); \
137     continue
138    
139     /*
140     * Macros used to cache often-referenced Tcl evaluation stack information
141     * in local variables. Note that a DECACHE_STACK_INFO()-CACHE_STACK_INFO()
142     * pair must surround any call inside TclExecuteByteCode (and a few other
143     * procedures that use this scheme) that could result in a recursive call
144     * to TclExecuteByteCode.
145     */
146    
147     #define CACHE_STACK_INFO() \
148     stackPtr = eePtr->stackPtr; \
149     stackTop = eePtr->stackTop
150    
151     #define DECACHE_STACK_INFO() \
152     eePtr->stackTop = stackTop
153    
154     /*
155     * Macros used to access items on the Tcl evaluation stack. PUSH_OBJECT
156     * increments the object's ref count since it makes the stack have another
157     * reference pointing to the object. However, POP_OBJECT does not decrement
158     * the ref count. This is because the stack may hold the only reference to
159     * the object, so the object would be destroyed if its ref count were
160     * decremented before the caller had a chance to, e.g., store it in a
161     * variable. It is the caller's responsibility to decrement the ref count
162     * when it is finished with an object.
163     *
164     * WARNING! It is essential that objPtr only appear once in the PUSH_OBJECT
165     * macro. The actual parameter might be an expression with side effects,
166     * and this ensures that it will be executed only once.
167     */
168    
169     #define PUSH_OBJECT(objPtr) \
170     Tcl_IncrRefCount(stackPtr[++stackTop] = (objPtr))
171    
172     #define POP_OBJECT() \
173     (stackPtr[stackTop--])
174    
175     /*
176     * Macros used to trace instruction execution. The macros TRACE,
177     * TRACE_WITH_OBJ, and O2S are only used inside TclExecuteByteCode.
178     * O2S is only used in TRACE* calls to get a string from an object.
179     */
180    
181     #ifdef TCL_COMPILE_DEBUG
182     #define TRACE(a) \
183     if (traceInstructions) { \
184     fprintf(stdout, "%2d: %2d (%u) %s ", iPtr->numLevels, stackTop, \
185     (unsigned int)(pc - codePtr->codeStart), \
186     GetOpcodeName(pc)); \
187     printf a; \
188     }
189     #define TRACE_WITH_OBJ(a, objPtr) \
190     if (traceInstructions) { \
191     fprintf(stdout, "%2d: %2d (%u) %s ", iPtr->numLevels, stackTop, \
192     (unsigned int)(pc - codePtr->codeStart), \
193     GetOpcodeName(pc)); \
194     printf a; \
195     TclPrintObject(stdout, (objPtr), 30); \
196     fprintf(stdout, "\n"); \
197     }
198     #define O2S(objPtr) \
199     Tcl_GetString(objPtr)
200     #else
201     #define TRACE(a)
202     #define TRACE_WITH_OBJ(a, objPtr)
203     #define O2S(objPtr)
204     #endif /* TCL_COMPILE_DEBUG */
205    
206     /*
207     * Declarations for local procedures to this file:
208     */
209    
210     static void CallTraceProcedure _ANSI_ARGS_((Tcl_Interp *interp,
211     Trace *tracePtr, Command *cmdPtr,
212     char *command, int numChars,
213     int objc, Tcl_Obj *objv[]));
214     static void DupCmdNameInternalRep _ANSI_ARGS_((Tcl_Obj *objPtr,
215     Tcl_Obj *copyPtr));
216     static int ExprAbsFunc _ANSI_ARGS_((Tcl_Interp *interp,
217     ExecEnv *eePtr, ClientData clientData));
218     static int ExprBinaryFunc _ANSI_ARGS_((Tcl_Interp *interp,
219     ExecEnv *eePtr, ClientData clientData));
220     static int ExprCallMathFunc _ANSI_ARGS_((Tcl_Interp *interp,
221     ExecEnv *eePtr, int objc, Tcl_Obj **objv));
222     static int ExprDoubleFunc _ANSI_ARGS_((Tcl_Interp *interp,
223     ExecEnv *eePtr, ClientData clientData));
224     static int ExprIntFunc _ANSI_ARGS_((Tcl_Interp *interp,
225     ExecEnv *eePtr, ClientData clientData));
226     static int ExprRandFunc _ANSI_ARGS_((Tcl_Interp *interp,
227     ExecEnv *eePtr, ClientData clientData));
228     static int ExprRoundFunc _ANSI_ARGS_((Tcl_Interp *interp,
229     ExecEnv *eePtr, ClientData clientData));
230     static int ExprSrandFunc _ANSI_ARGS_((Tcl_Interp *interp,
231     ExecEnv *eePtr, ClientData clientData));
232     static int ExprUnaryFunc _ANSI_ARGS_((Tcl_Interp *interp,
233     ExecEnv *eePtr, ClientData clientData));
234     #ifdef TCL_COMPILE_STATS
235     static int EvalStatsCmd _ANSI_ARGS_((ClientData clientData,
236     Tcl_Interp *interp, int argc, char **argv));
237     #endif
238     static void FreeCmdNameInternalRep _ANSI_ARGS_((
239     Tcl_Obj *objPtr));
240     #ifdef TCL_COMPILE_DEBUG
241     static char * GetOpcodeName _ANSI_ARGS_((unsigned char *pc));
242     #endif
243     static ExceptionRange * GetExceptRangeForPc _ANSI_ARGS_((unsigned char *pc,
244     int catchOnly, ByteCode* codePtr));
245     static char * GetSrcInfoForPc _ANSI_ARGS_((unsigned char *pc,
246     ByteCode* codePtr, int *lengthPtr));
247     static void GrowEvaluationStack _ANSI_ARGS_((ExecEnv *eePtr));
248     static void IllegalExprOperandType _ANSI_ARGS_((
249     Tcl_Interp *interp, unsigned char *pc,
250     Tcl_Obj *opndPtr));
251     static void InitByteCodeExecution _ANSI_ARGS_((
252     Tcl_Interp *interp));
253     #ifdef TCL_COMPILE_DEBUG
254     static void PrintByteCodeInfo _ANSI_ARGS_((ByteCode *codePtr));
255     #endif
256     static int SetCmdNameFromAny _ANSI_ARGS_((Tcl_Interp *interp,
257     Tcl_Obj *objPtr));
258     #ifdef TCL_COMPILE_DEBUG
259     static char * StringForResultCode _ANSI_ARGS_((int result));
260     static void ValidatePcAndStackTop _ANSI_ARGS_((
261     ByteCode *codePtr, unsigned char *pc,
262     int stackTop, int stackLowerBound,
263     int stackUpperBound));
264     #endif
265     static int VerifyExprObjType _ANSI_ARGS_((Tcl_Interp *interp,
266     Tcl_Obj *objPtr));
267    
268     /*
269     * Table describing the built-in math functions. Entries in this table are
270     * indexed by the values of the INST_CALL_BUILTIN_FUNC instruction's
271     * operand byte.
272     */
273    
274     BuiltinFunc builtinFuncTable[] = {
275     #ifndef TCL_NO_MATH
276     {"acos", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) acos},
277     {"asin", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) asin},
278     {"atan", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) atan},
279     {"atan2", 2, {TCL_DOUBLE, TCL_DOUBLE}, ExprBinaryFunc, (ClientData) atan2},
280     {"ceil", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) ceil},
281     {"cos", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) cos},
282     {"cosh", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) cosh},
283     {"exp", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) exp},
284     {"floor", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) floor},
285     {"fmod", 2, {TCL_DOUBLE, TCL_DOUBLE}, ExprBinaryFunc, (ClientData) fmod},
286     {"hypot", 2, {TCL_DOUBLE, TCL_DOUBLE}, ExprBinaryFunc, (ClientData) hypot},
287     {"log", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) log},
288     {"log10", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) log10},
289     {"pow", 2, {TCL_DOUBLE, TCL_DOUBLE}, ExprBinaryFunc, (ClientData) pow},
290     {"sin", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) sin},
291     {"sinh", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) sinh},
292     {"sqrt", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) sqrt},
293     {"tan", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) tan},
294     {"tanh", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) tanh},
295     #endif
296     {"abs", 1, {TCL_EITHER}, ExprAbsFunc, 0},
297     {"double", 1, {TCL_EITHER}, ExprDoubleFunc, 0},
298     {"int", 1, {TCL_EITHER}, ExprIntFunc, 0},
299     {"rand", 0, {TCL_EITHER}, ExprRandFunc, 0}, /* NOTE: rand takes no args. */
300     {"round", 1, {TCL_EITHER}, ExprRoundFunc, 0},
301     {"srand", 1, {TCL_INT}, ExprSrandFunc, 0},
302     {0},
303     };
304    
305     /*
306     * The structure below defines the command name Tcl object type by means of
307     * procedures that can be invoked by generic object code. Objects of this
308     * type cache the Command pointer that results from looking up command names
309     * in the command hashtable. Such objects appear as the zeroth ("command
310     * name") argument in a Tcl command.
311     */
312    
313     Tcl_ObjType tclCmdNameType = {
314     "cmdName", /* name */
315     FreeCmdNameInternalRep, /* freeIntRepProc */
316     DupCmdNameInternalRep, /* dupIntRepProc */
317     (Tcl_UpdateStringProc *) NULL, /* updateStringProc */
318     SetCmdNameFromAny /* setFromAnyProc */
319     };
320    
321     /*
322     *----------------------------------------------------------------------
323     *
324     * InitByteCodeExecution --
325     *
326     * This procedure is called once to initialize the Tcl bytecode
327     * interpreter.
328     *
329     * Results:
330     * None.
331     *
332     * Side effects:
333     * This procedure initializes the array of instruction names. If
334     * compiling with the TCL_COMPILE_STATS flag, it initializes the
335     * array that counts the executions of each instruction and it
336     * creates the "evalstats" command. It also registers the command name
337     * Tcl_ObjType. It also establishes the link between the Tcl
338     * "tcl_traceExec" and C "tclTraceExec" variables.
339     *
340     *----------------------------------------------------------------------
341     */
342    
343     static void
344     InitByteCodeExecution(interp)
345     Tcl_Interp *interp; /* Interpreter for which the Tcl variable
346     * "tcl_traceExec" is linked to control
347     * instruction tracing. */
348     {
349     Tcl_RegisterObjType(&tclCmdNameType);
350     if (Tcl_LinkVar(interp, "tcl_traceExec", (char *) &tclTraceExec,
351     TCL_LINK_INT) != TCL_OK) {
352     panic("InitByteCodeExecution: can't create link for tcl_traceExec variable");
353     }
354    
355     #ifdef TCL_COMPILE_STATS
356     Tcl_CreateCommand(interp, "evalstats", EvalStatsCmd,
357     (ClientData) NULL, (Tcl_CmdDeleteProc *) NULL);
358     #endif /* TCL_COMPILE_STATS */
359     }
360    
361     /*
362     *----------------------------------------------------------------------
363     *
364     * TclCreateExecEnv --
365     *
366     * This procedure creates a new execution environment for Tcl bytecode
367     * execution. An ExecEnv points to a Tcl evaluation stack. An ExecEnv
368     * is typically created once for each Tcl interpreter (Interp
369     * structure) and recursively passed to TclExecuteByteCode to execute
370     * ByteCode sequences for nested commands.
371     *
372     * Results:
373     * A newly allocated ExecEnv is returned. This points to an empty
374     * evaluation stack of the standard initial size.
375     *
376     * Side effects:
377     * The bytecode interpreter is also initialized here, as this
378     * procedure will be called before any call to TclExecuteByteCode.
379     *
380     *----------------------------------------------------------------------
381     */
382    
383     #define TCL_STACK_INITIAL_SIZE 2000
384    
385     ExecEnv *
386     TclCreateExecEnv(interp)
387     Tcl_Interp *interp; /* Interpreter for which the execution
388     * environment is being created. */
389     {
390     ExecEnv *eePtr = (ExecEnv *) ckalloc(sizeof(ExecEnv));
391    
392     eePtr->stackPtr = (Tcl_Obj **)
393     ckalloc((unsigned) (TCL_STACK_INITIAL_SIZE * sizeof(Tcl_Obj *)));
394     eePtr->stackTop = -1;
395     eePtr->stackEnd = (TCL_STACK_INITIAL_SIZE - 1);
396    
397     Tcl_MutexLock(&execMutex);
398     if (!execInitialized) {
399     TclInitAuxDataTypeTable();
400     InitByteCodeExecution(interp);
401     execInitialized = 1;
402     }
403     Tcl_MutexUnlock(&execMutex);
404    
405     return eePtr;
406     }
407     #undef TCL_STACK_INITIAL_SIZE
408    
409     /*
410     *----------------------------------------------------------------------
411     *
412     * TclDeleteExecEnv --
413     *
414     * Frees the storage for an ExecEnv.
415     *
416     * Results:
417     * None.
418     *
419     * Side effects:
420     * Storage for an ExecEnv and its contained storage (e.g. the
421     * evaluation stack) is freed.
422     *
423     *----------------------------------------------------------------------
424     */
425    
426     void
427     TclDeleteExecEnv(eePtr)
428     ExecEnv *eePtr; /* Execution environment to free. */
429     {
430     ckfree((char *) eePtr->stackPtr);
431     ckfree((char *) eePtr);
432     }
433    
434     /*
435     *----------------------------------------------------------------------
436     *
437     * TclFinalizeExecution --
438     *
439     * Finalizes the execution environment setup so that it can be
440     * later reinitialized.
441     *
442     * Results:
443     * None.
444     *
445     * Side effects:
446     * After this call, the next time TclCreateExecEnv will be called
447     * it will call InitByteCodeExecution.
448     *
449     *----------------------------------------------------------------------
450     */
451    
452     void
453     TclFinalizeExecution()
454     {
455     Tcl_MutexLock(&execMutex);
456     execInitialized = 0;
457     Tcl_MutexUnlock(&execMutex);
458     TclFinalizeAuxDataTypeTable();
459     }
460    
461     /*
462     *----------------------------------------------------------------------
463     *
464     * GrowEvaluationStack --
465     *
466     * This procedure grows a Tcl evaluation stack stored in an ExecEnv.
467     *
468     * Results:
469     * None.
470     *
471     * Side effects:
472     * The size of the evaluation stack is doubled.
473     *
474     *----------------------------------------------------------------------
475     */
476    
477     static void
478     GrowEvaluationStack(eePtr)
479     register ExecEnv *eePtr; /* Points to the ExecEnv with an evaluation
480     * stack to enlarge. */
481     {
482     /*
483     * The current Tcl stack elements are stored from eePtr->stackPtr[0]
484     * to eePtr->stackPtr[eePtr->stackEnd] (inclusive).
485     */
486    
487     int currElems = (eePtr->stackEnd + 1);
488     int newElems = 2*currElems;
489     int currBytes = currElems * sizeof(Tcl_Obj *);
490     int newBytes = 2*currBytes;
491     Tcl_Obj **newStackPtr = (Tcl_Obj **) ckalloc((unsigned) newBytes);
492    
493     /*
494     * Copy the existing stack items to the new stack space, free the old
495     * storage if appropriate, and mark new space as malloc'ed.
496     */
497    
498     memcpy((VOID *) newStackPtr, (VOID *) eePtr->stackPtr,
499     (size_t) currBytes);
500     ckfree((char *) eePtr->stackPtr);
501     eePtr->stackPtr = newStackPtr;
502     eePtr->stackEnd = (newElems - 1); /* i.e. index of last usable item */
503     }
504    
505     /*
506     *----------------------------------------------------------------------
507     *
508     * TclExecuteByteCode --
509     *
510     * This procedure executes the instructions of a ByteCode structure.
511     * It returns when a "done" instruction is executed or an error occurs.
512     *
513     * Results:
514     * The return value is one of the return codes defined in tcl.h
515     * (such as TCL_OK), and interp->objResultPtr refers to a Tcl object
516     * that either contains the result of executing the code or an
517     * error message.
518     *
519     * Side effects:
520     * Almost certainly, depending on the ByteCode's instructions.
521     *
522     *----------------------------------------------------------------------
523     */
524    
525     int
526     TclExecuteByteCode(interp, codePtr)
527     Tcl_Interp *interp; /* Token for command interpreter. */
528     ByteCode *codePtr; /* The bytecode sequence to interpret. */
529     {
530     Interp *iPtr = (Interp *) interp;
531     ExecEnv *eePtr = iPtr->execEnvPtr;
532     /* Points to the execution environment. */
533     register Tcl_Obj **stackPtr = eePtr->stackPtr;
534     /* Cached evaluation stack base pointer. */
535     register int stackTop = eePtr->stackTop;
536     /* Cached top index of evaluation stack. */
537     register unsigned char *pc = codePtr->codeStart;
538     /* The current program counter. */
539     int opnd; /* Current instruction's operand byte. */
540     int pcAdjustment; /* Hold pc adjustment after instruction. */
541     int initStackTop = stackTop;/* Stack top at start of execution. */
542     ExceptionRange *rangePtr; /* Points to closest loop or catch exception
543     * range enclosing the pc. Used by various
544     * instructions and processCatch to
545     * process break, continue, and errors. */
546     int result = TCL_OK; /* Return code returned after execution. */
547     int traceInstructions = (tclTraceExec == 3);
548     Tcl_Obj *valuePtr, *value2Ptr, *objPtr;
549     char *bytes;
550     int length;
551     long i;
552    
553     /*
554     * This procedure uses a stack to hold information about catch commands.
555     * This information is the current operand stack top when starting to
556     * execute the code for each catch command. It starts out with stack-
557     * allocated space but uses dynamically-allocated storage if needed.
558     */
559    
560     #define STATIC_CATCH_STACK_SIZE 4
561     int (catchStackStorage[STATIC_CATCH_STACK_SIZE]);
562     int *catchStackPtr = catchStackStorage;
563     int catchTop = -1;
564    
565     #ifdef TCL_COMPILE_DEBUG
566     if (tclTraceExec >= 2) {
567     PrintByteCodeInfo(codePtr);
568     fprintf(stdout, " Starting stack top=%d\n", eePtr->stackTop);
569     fflush(stdout);
570     }
571     #endif
572    
573     #ifdef TCL_COMPILE_STATS
574     iPtr->stats.numExecutions++;
575     #endif
576    
577     /*
578     * Make sure the catch stack is large enough to hold the maximum number
579     * of catch commands that could ever be executing at the same time. This
580     * will be no more than the exception range array's depth.
581     */
582    
583     if (codePtr->maxExceptDepth > STATIC_CATCH_STACK_SIZE) {
584     catchStackPtr = (int *)
585     ckalloc(codePtr->maxExceptDepth * sizeof(int));
586     }
587    
588     /*
589     * Make sure the stack has enough room to execute this ByteCode.
590     */
591    
592     while ((stackTop + codePtr->maxStackDepth) > eePtr->stackEnd) {
593     GrowEvaluationStack(eePtr);
594     stackPtr = eePtr->stackPtr;
595     }
596    
597     /*
598     * Loop executing instructions until a "done" instruction, a TCL_RETURN,
599     * or some error.
600     */
601    
602     for (;;) {
603     #ifdef TCL_COMPILE_DEBUG
604     ValidatePcAndStackTop(codePtr, pc, stackTop, initStackTop,
605     eePtr->stackEnd);
606     #else /* not TCL_COMPILE_DEBUG */
607     if (traceInstructions) {
608     fprintf(stdout, "%2d: %2d ", iPtr->numLevels, stackTop);
609     TclPrintInstruction(codePtr, pc);
610     fflush(stdout);
611     }
612     #endif /* TCL_COMPILE_DEBUG */
613    
614     #ifdef TCL_COMPILE_STATS
615     iPtr->stats.instructionCount[*pc]++;
616     #endif
617     switch (*pc) {
618     case INST_DONE:
619     /*
620     * Pop the topmost object from the stack, set the interpreter's
621     * object result to point to it, and return.
622     */
623     valuePtr = POP_OBJECT();
624     Tcl_SetObjResult(interp, valuePtr);
625     TclDecrRefCount(valuePtr);
626     if (stackTop != initStackTop) {
627     fprintf(stderr, "\nTclExecuteByteCode: done instruction at pc %u: stack top %d != entry stack top %d\n",
628     (unsigned int)(pc - codePtr->codeStart),
629     (unsigned int) stackTop,
630     (unsigned int) initStackTop);
631     panic("TclExecuteByteCode execution failure: end stack top != start stack top");
632     }
633     TRACE_WITH_OBJ(("=> return code=%d, result=", result),
634     iPtr->objResultPtr);
635     #ifdef TCL_COMPILE_DEBUG
636     if (traceInstructions) {
637     fprintf(stdout, "\n");
638     }
639     #endif
640     goto done;
641    
642     case INST_PUSH1:
643     #ifdef TCL_COMPILE_DEBUG
644     valuePtr = codePtr->objArrayPtr[TclGetUInt1AtPtr(pc+1)];
645     PUSH_OBJECT(valuePtr);
646     TRACE_WITH_OBJ(("%u => ", TclGetInt1AtPtr(pc+1)), valuePtr);
647     #else
648     PUSH_OBJECT(codePtr->objArrayPtr[TclGetUInt1AtPtr(pc+1)]);
649     #endif /* TCL_COMPILE_DEBUG */
650     ADJUST_PC(2);
651    
652     case INST_PUSH4:
653     valuePtr = codePtr->objArrayPtr[TclGetUInt4AtPtr(pc+1)];
654     PUSH_OBJECT(valuePtr);
655     TRACE_WITH_OBJ(("%u => ", TclGetUInt4AtPtr(pc+1)), valuePtr);
656     ADJUST_PC(5);
657    
658     case INST_POP:
659     valuePtr = POP_OBJECT();
660     TRACE_WITH_OBJ(("=> discarding "), valuePtr);
661     TclDecrRefCount(valuePtr); /* finished with pop'ed object. */
662     ADJUST_PC(1);
663    
664     case INST_DUP:
665     valuePtr = stackPtr[stackTop];
666     PUSH_OBJECT(Tcl_DuplicateObj(valuePtr));
667     TRACE_WITH_OBJ(("=> "), valuePtr);
668     ADJUST_PC(1);
669    
670     case INST_CONCAT1:
671     opnd = TclGetUInt1AtPtr(pc+1);
672     {
673     Tcl_Obj *concatObjPtr;
674     int totalLen = 0;
675    
676     /*
677     * Concatenate strings (with no separators) from the top
678     * opnd items on the stack starting with the deepest item.
679     * First, determine how many characters are needed.
680     */
681    
682     for (i = (stackTop - (opnd-1)); i <= stackTop; i++) {
683     bytes = Tcl_GetStringFromObj(stackPtr[i], &length);
684     if (bytes != NULL) {
685     totalLen += length;
686     }
687     }
688    
689     /*
690     * Initialize the new append string object by appending the
691     * strings of the opnd stack objects. Also pop the objects.
692     */
693    
694     TclNewObj(concatObjPtr);
695     if (totalLen > 0) {
696     char *p = (char *) ckalloc((unsigned) (totalLen + 1));
697     concatObjPtr->bytes = p;
698     concatObjPtr->length = totalLen;
699     for (i = (stackTop - (opnd-1)); i <= stackTop; i++) {
700     valuePtr = stackPtr[i];
701     bytes = Tcl_GetStringFromObj(valuePtr, &length);
702     if (bytes != NULL) {
703     memcpy((VOID *) p, (VOID *) bytes,
704     (size_t) length);
705     p += length;
706     }
707     TclDecrRefCount(valuePtr);
708     }
709     *p = '\0';
710     } else {
711     for (i = (stackTop - (opnd-1)); i <= stackTop; i++) {
712     Tcl_DecrRefCount(stackPtr[i]);
713     }
714     }
715     stackTop -= opnd;
716    
717     PUSH_OBJECT(concatObjPtr);
718     TRACE_WITH_OBJ(("%u => ", opnd), concatObjPtr);
719     ADJUST_PC(2);
720     }
721    
722     case INST_INVOKE_STK4:
723     opnd = TclGetUInt4AtPtr(pc+1);
724     pcAdjustment = 5;
725     goto doInvocation;
726    
727     case INST_INVOKE_STK1:
728     opnd = TclGetUInt1AtPtr(pc+1);
729     pcAdjustment = 2;
730    
731     doInvocation:
732     {
733     int objc = opnd; /* The number of arguments. */
734     Tcl_Obj **objv; /* The array of argument objects. */
735     Command *cmdPtr; /* Points to command's Command struct. */
736     int newPcOffset; /* New inst offset for break, continue. */
737     #ifdef TCL_COMPILE_DEBUG
738     int isUnknownCmd = 0;
739     char cmdNameBuf[21];
740     #endif /* TCL_COMPILE_DEBUG */
741    
742     /*
743     * If the interpreter was deleted, return an error.
744     */
745    
746     if (iPtr->flags & DELETED) {
747     Tcl_ResetResult(interp);
748     Tcl_AppendToObj(Tcl_GetObjResult(interp),
749     "attempt to call eval in deleted interpreter", -1);
750     Tcl_SetErrorCode(interp, "CORE", "IDELETE",
751     "attempt to call eval in deleted interpreter",
752     (char *) NULL);
753     result = TCL_ERROR;
754     goto checkForCatch;
755     }
756    
757     /*
758     * Find the procedure to execute this command. If the
759     * command is not found, handle it with the "unknown" proc.
760     */
761    
762     objv = &(stackPtr[stackTop - (objc-1)]);
763     cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, objv[0]);
764     if (cmdPtr == NULL) {
765     cmdPtr = (Command *) Tcl_FindCommand(interp, "unknown",
766     (Tcl_Namespace *) NULL, TCL_GLOBAL_ONLY);
767     if (cmdPtr == NULL) {
768     Tcl_ResetResult(interp);
769     Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
770     "invalid command name \"",
771     Tcl_GetString(objv[0]), "\"",
772     (char *) NULL);
773     TRACE(("%u => unknown proc not found: ", objc));
774     result = TCL_ERROR;
775     goto checkForCatch;
776     }
777     #ifdef TCL_COMPILE_DEBUG
778     isUnknownCmd = 1;
779     #endif /*TCL_COMPILE_DEBUG*/
780     stackTop++; /* need room for new inserted objv[0] */
781     for (i = objc-1; i >= 0; i--) {
782     objv[i+1] = objv[i];
783     }
784     objc++;
785     objv[0] = Tcl_NewStringObj("unknown", -1);
786     Tcl_IncrRefCount(objv[0]);
787     }
788    
789     /*
790     * Call any trace procedures.
791     */
792    
793     if (iPtr->tracePtr != NULL) {
794     Trace *tracePtr, *nextTracePtr;
795    
796     for (tracePtr = iPtr->tracePtr; tracePtr != NULL;
797     tracePtr = nextTracePtr) {
798     nextTracePtr = tracePtr->nextPtr;
799     if (iPtr->numLevels <= tracePtr->level) {
800     int numChars;
801     char *cmd = GetSrcInfoForPc(pc, codePtr,
802     &numChars);
803     if (cmd != NULL) {
804     DECACHE_STACK_INFO();
805     CallTraceProcedure(interp, tracePtr, cmdPtr,
806     cmd, numChars, objc, objv);
807     CACHE_STACK_INFO();
808     }
809     }
810     }
811     }
812    
813     /*
814     * Finally, invoke the command's Tcl_ObjCmdProc. First reset
815     * the interpreter's string and object results to their
816     * default empty values since they could have gotten changed
817     * by earlier invocations.
818     */
819    
820     Tcl_ResetResult(interp);
821     if (tclTraceExec >= 2) {
822     #ifdef TCL_COMPILE_DEBUG
823     if (traceInstructions) {
824     strncpy(cmdNameBuf, Tcl_GetString(objv[0]), 20);
825     TRACE(("%u => call ", (isUnknownCmd? objc-1:objc)));
826     } else {
827     fprintf(stdout, "%d: (%u) invoking ",
828     iPtr->numLevels,
829     (unsigned int)(pc - codePtr->codeStart));
830     }
831     for (i = 0; i < objc; i++) {
832     TclPrintObject(stdout, objv[i], 15);
833     fprintf(stdout, " ");
834     }
835     fprintf(stdout, "\n");
836     fflush(stdout);
837     #else /* TCL_COMPILE_DEBUG */
838     fprintf(stdout, "%d: (%u) invoking %s\n",
839     iPtr->numLevels,
840     (unsigned int)(pc - codePtr->codeStart),
841     Tcl_GetString(objv[0]));
842     #endif /*TCL_COMPILE_DEBUG*/
843     }
844    
845     iPtr->cmdCount++;
846     DECACHE_STACK_INFO();
847     result = (*cmdPtr->objProc)(cmdPtr->objClientData, interp,
848     objc, objv);
849     if (Tcl_AsyncReady()) {
850     result = Tcl_AsyncInvoke(interp, result);
851     }
852     CACHE_STACK_INFO();
853    
854     /*
855     * If the interpreter has a non-empty string result, the
856     * result object is either empty or stale because some
857     * procedure set interp->result directly. If so, move the
858     * string result to the result object, then reset the
859     * string result.
860     */
861    
862     if (*(iPtr->result) != 0) {
863     (void) Tcl_GetObjResult(interp);
864     }
865    
866     /*
867     * Pop the objc top stack elements and decrement their ref
868     * counts.
869     */
870    
871     for (i = 0; i < objc; i++) {
872     valuePtr = stackPtr[stackTop];
873     TclDecrRefCount(valuePtr);
874     stackTop--;
875     }
876    
877     /*
878     * Process the result of the Tcl_ObjCmdProc call.
879     */
880    
881     switch (result) {
882     case TCL_OK:
883     /*
884     * Push the call's object result and continue execution
885     * with the next instruction.
886     */
887     PUSH_OBJECT(Tcl_GetObjResult(interp));
888     TRACE_WITH_OBJ(("%u => ...after \"%.20s\", result=",
889     objc, cmdNameBuf), Tcl_GetObjResult(interp));
890     ADJUST_PC(pcAdjustment);
891    
892     case TCL_BREAK:
893     case TCL_CONTINUE:
894     /*
895     * The invoked command requested a break or continue.
896     * Find the closest enclosing loop or catch exception
897     * range, if any. If a loop is found, terminate its
898     * execution or skip to its next iteration. If the
899     * closest is a catch exception range, jump to its
900     * catchOffset. If no enclosing range is found, stop
901     * execution and return the TCL_BREAK or TCL_CONTINUE.
902     */
903     rangePtr = GetExceptRangeForPc(pc, /*catchOnly*/ 0,
904     codePtr);
905     if (rangePtr == NULL) {
906     TRACE(("%u => ... after \"%.20s\", no encl. loop or catch, returning %s\n",
907     objc, cmdNameBuf,
908     StringForResultCode(result)));
909     goto abnormalReturn; /* no catch exists to check */
910     }
911     newPcOffset = 0;
912     switch (rangePtr->type) {
913     case LOOP_EXCEPTION_RANGE:
914     if (result == TCL_BREAK) {
915     newPcOffset = rangePtr->breakOffset;
916     } else if (rangePtr->continueOffset == -1) {
917     TRACE(("%u => ... after \"%.20s\", %s, loop w/o continue, checking for catch\n",
918     objc, cmdNameBuf,
919     StringForResultCode(result)));
920     goto checkForCatch;
921     } else {
922     newPcOffset = rangePtr->continueOffset;
923     }
924     TRACE(("%u => ... after \"%.20s\", %s, range at %d, new pc %d\n",
925     objc, cmdNameBuf,
926     StringForResultCode(result),
927     rangePtr->codeOffset, newPcOffset));
928     break;
929     case CATCH_EXCEPTION_RANGE:
930     TRACE(("%u => ... after \"%.20s\", %s...\n",
931     objc, cmdNameBuf,
932     StringForResultCode(result)));
933     goto processCatch; /* it will use rangePtr */
934     default:
935     panic("TclExecuteByteCode: bad ExceptionRange type\n");
936     }
937     result = TCL_OK;
938     pc = (codePtr->codeStart + newPcOffset);
939     continue; /* restart outer instruction loop at pc */
940    
941     case TCL_ERROR:
942     /*
943     * The invoked command returned an error. Look for an
944     * enclosing catch exception range, if any.
945     */
946     TRACE_WITH_OBJ(("%u => ... after \"%.20s\", TCL_ERROR ",
947     objc, cmdNameBuf), Tcl_GetObjResult(interp));
948     goto checkForCatch;
949    
950     case TCL_RETURN:
951     /*
952     * The invoked command requested that the current
953     * procedure stop execution and return. First check
954     * for an enclosing catch exception range, if any.
955     */
956     TRACE(("%u => ... after \"%.20s\", TCL_RETURN\n",
957     objc, cmdNameBuf));
958     goto checkForCatch;
959    
960     default:
961     TRACE_WITH_OBJ(("%u => ... after \"%.20s\", OTHER RETURN CODE %d ",
962     objc, cmdNameBuf, result),
963     Tcl_GetObjResult(interp));
964     goto checkForCatch;
965     }
966     }
967    
968     case INST_EVAL_STK:
969     objPtr = POP_OBJECT();
970     DECACHE_STACK_INFO();
971     result = Tcl_EvalObjEx(interp, objPtr, 0);
972     CACHE_STACK_INFO();
973     if (result == TCL_OK) {
974     /*
975     * Normal return; push the eval's object result.
976     */
977     PUSH_OBJECT(Tcl_GetObjResult(interp));
978     TRACE_WITH_OBJ(("\"%.30s\" => ", O2S(objPtr)),
979     Tcl_GetObjResult(interp));
980     TclDecrRefCount(objPtr);
981     ADJUST_PC(1);
982     } else if ((result == TCL_BREAK) || (result == TCL_CONTINUE)) {
983     /*
984     * Find the closest enclosing loop or catch exception range,
985     * if any. If a loop is found, terminate its execution or
986     * skip to its next iteration. If the closest is a catch
987     * exception range, jump to its catchOffset. If no enclosing
988     * range is found, stop execution and return that same
989     * TCL_BREAK or TCL_CONTINUE.
990     */
991    
992     int newPcOffset = 0; /* Pc offset computed during break,
993     * continue, error processing. Init.
994     * to avoid compiler warning. */
995    
996     rangePtr = GetExceptRangeForPc(pc, /*catchOnly*/ 0,
997     codePtr);
998     if (rangePtr == NULL) {
999     TRACE(("\"%.30s\" => no encl. loop or catch, returning %s\n",
1000     O2S(objPtr), StringForResultCode(result)));
1001     Tcl_DecrRefCount(objPtr);
1002     goto abnormalReturn; /* no catch exists to check */
1003     }
1004     switch (rangePtr->type) {
1005     case LOOP_EXCEPTION_RANGE:
1006     if (result == TCL_BREAK) {
1007     newPcOffset = rangePtr->breakOffset;
1008     } else if (rangePtr->continueOffset == -1) {
1009     TRACE(("\"%.30s\" => %s, loop w/o continue, checking for catch\n",
1010     O2S(objPtr), StringForResultCode(result)));
1011     Tcl_DecrRefCount(objPtr);
1012     goto checkForCatch;
1013     } else {
1014     newPcOffset = rangePtr->continueOffset;
1015     }
1016     result = TCL_OK;
1017     TRACE_WITH_OBJ(("\"%.30s\" => %s, range at %d, new pc %d ",
1018     O2S(objPtr), StringForResultCode(result),
1019     rangePtr->codeOffset, newPcOffset), valuePtr);
1020     break;
1021     case CATCH_EXCEPTION_RANGE:
1022     TRACE_WITH_OBJ(("\"%.30s\" => %s ",
1023     O2S(objPtr), StringForResultCode(result)),
1024     valuePtr);
1025     Tcl_DecrRefCount(objPtr);
1026     goto processCatch; /* it will use rangePtr */
1027     default:
1028     panic("TclExecuteByteCode: unrecognized ExceptionRange type %d\n", rangePtr->type);
1029     }
1030     Tcl_DecrRefCount(objPtr);
1031     pc = (codePtr->codeStart + newPcOffset);
1032     continue; /* restart outer instruction loop at pc */
1033     } else { /* eval returned TCL_ERROR, TCL_RETURN, unknown code */
1034     TRACE_WITH_OBJ(("\"%.30s\" => ERROR: ", O2S(objPtr)),
1035     Tcl_GetObjResult(interp));
1036     Tcl_DecrRefCount(objPtr);
1037     goto checkForCatch;
1038     }
1039    
1040     case INST_EXPR_STK:
1041     objPtr = POP_OBJECT();
1042     Tcl_ResetResult(interp);
1043     DECACHE_STACK_INFO();
1044     result = Tcl_ExprObj(interp, objPtr, &valuePtr);
1045     CACHE_STACK_INFO();
1046     if (result != TCL_OK) {
1047     TRACE_WITH_OBJ(("\"%.30s\" => ERROR: ",
1048     O2S(objPtr)), Tcl_GetObjResult(interp));
1049     Tcl_DecrRefCount(objPtr);
1050     goto checkForCatch;
1051     }
1052     stackPtr[++stackTop] = valuePtr; /* already has right refct */
1053     TRACE_WITH_OBJ(("\"%.30s\" => ", O2S(objPtr)), valuePtr);
1054     TclDecrRefCount(objPtr);
1055     ADJUST_PC(1);
1056    
1057     case INST_LOAD_SCALAR1:
1058     #ifdef TCL_COMPILE_DEBUG
1059     opnd = TclGetUInt1AtPtr(pc+1);
1060     DECACHE_STACK_INFO();
1061     valuePtr = TclGetIndexedScalar(interp, opnd,
1062     /*leaveErrorMsg*/ 1);
1063     CACHE_STACK_INFO();
1064     if (valuePtr == NULL) {
1065     TRACE_WITH_OBJ(("%u => ERROR: ", opnd),
1066     Tcl_GetObjResult(interp));
1067     result = TCL_ERROR;
1068     goto checkForCatch;
1069     }
1070     PUSH_OBJECT(valuePtr);
1071     TRACE_WITH_OBJ(("%u => ", opnd), valuePtr);
1072     #else /* TCL_COMPILE_DEBUG */
1073     DECACHE_STACK_INFO();
1074     opnd = TclGetUInt1AtPtr(pc+1);
1075     valuePtr = TclGetIndexedScalar(interp, opnd, /*leaveErrorMsg*/ 1);
1076     CACHE_STACK_INFO();
1077     if (valuePtr == NULL) {
1078     result = TCL_ERROR;
1079     goto checkForCatch;
1080     }
1081     PUSH_OBJECT(valuePtr);
1082     #endif /* TCL_COMPILE_DEBUG */
1083     ADJUST_PC(2);
1084    
1085     case INST_LOAD_SCALAR4:
1086     opnd = TclGetUInt4AtPtr(pc+1);
1087     DECACHE_STACK_INFO();
1088     valuePtr = TclGetIndexedScalar(interp, opnd,
1089     /*leaveErrorMsg*/ 1);
1090     CACHE_STACK_INFO();
1091     if (valuePtr == NULL) {
1092     TRACE_WITH_OBJ(("%u => ERROR: ", opnd),
1093     Tcl_GetObjResult(interp));
1094     result = TCL_ERROR;
1095     goto checkForCatch;
1096     }
1097     PUSH_OBJECT(valuePtr);
1098     TRACE_WITH_OBJ(("%u => ", opnd), valuePtr);
1099     ADJUST_PC(5);
1100    
1101     case INST_LOAD_SCALAR_STK:
1102     objPtr = POP_OBJECT(); /* scalar name */
1103     DECACHE_STACK_INFO();
1104     valuePtr = Tcl_ObjGetVar2(interp, objPtr, NULL, TCL_LEAVE_ERR_MSG);
1105     CACHE_STACK_INFO();
1106     if (valuePtr == NULL) {
1107     TRACE_WITH_OBJ(("\"%.30s\" => ERROR: ", O2S(objPtr)),
1108     Tcl_GetObjResult(interp));
1109     Tcl_DecrRefCount(objPtr);
1110     result = TCL_ERROR;
1111     goto checkForCatch;
1112     }
1113     PUSH_OBJECT(valuePtr);
1114     TRACE_WITH_OBJ(("\"%.30s\" => ", O2S(objPtr)), valuePtr);
1115     TclDecrRefCount(objPtr);
1116     ADJUST_PC(1);
1117    
1118     case INST_LOAD_ARRAY4:
1119     opnd = TclGetUInt4AtPtr(pc+1);
1120     pcAdjustment = 5;
1121     goto doLoadArray;
1122    
1123     case INST_LOAD_ARRAY1:
1124     opnd = TclGetUInt1AtPtr(pc+1);
1125     pcAdjustment = 2;
1126    
1127     doLoadArray:
1128     {
1129     Tcl_Obj *elemPtr = POP_OBJECT();
1130    
1131     DECACHE_STACK_INFO();
1132     valuePtr = TclGetElementOfIndexedArray(interp, opnd,
1133     elemPtr, /*leaveErrorMsg*/ 1);
1134     CACHE_STACK_INFO();
1135     if (valuePtr == NULL) {
1136     TRACE_WITH_OBJ(("%u \"%.30s\" => ERROR: ",
1137     opnd, O2S(elemPtr)), Tcl_GetObjResult(interp));
1138     Tcl_DecrRefCount(elemPtr);
1139     result = TCL_ERROR;
1140     goto checkForCatch;
1141     }
1142     PUSH_OBJECT(valuePtr);
1143     TRACE_WITH_OBJ(("%u \"%.30s\" => ",
1144     opnd, O2S(elemPtr)),valuePtr);
1145     TclDecrRefCount(elemPtr);
1146     }
1147     ADJUST_PC(pcAdjustment);
1148    
1149     case INST_LOAD_ARRAY_STK:
1150     {
1151     Tcl_Obj *elemPtr = POP_OBJECT();
1152    
1153     objPtr = POP_OBJECT(); /* array name */
1154     DECACHE_STACK_INFO();
1155     valuePtr = Tcl_ObjGetVar2(interp, objPtr, elemPtr,
1156     TCL_LEAVE_ERR_MSG);
1157     CACHE_STACK_INFO();
1158     if (valuePtr == NULL) {
1159     TRACE_WITH_OBJ(("\"%.30s(%.30s)\" => ERROR: ",
1160     O2S(objPtr), O2S(elemPtr)),
1161     Tcl_GetObjResult(interp));
1162     Tcl_DecrRefCount(objPtr);
1163     Tcl_DecrRefCount(elemPtr);
1164     result = TCL_ERROR;
1165     goto checkForCatch;
1166     }
1167     PUSH_OBJECT(valuePtr);
1168     TRACE_WITH_OBJ(("\"%.30s(%.30s)\" => ",
1169     O2S(objPtr), O2S(elemPtr)), valuePtr);
1170     TclDecrRefCount(objPtr);
1171     TclDecrRefCount(elemPtr);
1172     }
1173     ADJUST_PC(1);
1174    
1175     case INST_LOAD_STK:
1176     objPtr = POP_OBJECT(); /* variable name */
1177     DECACHE_STACK_INFO();
1178     valuePtr = Tcl_ObjGetVar2(interp, objPtr, NULL, TCL_LEAVE_ERR_MSG);
1179     CACHE_STACK_INFO();
1180     if (valuePtr == NULL) {
1181     TRACE_WITH_OBJ(("\"%.30s\" => ERROR: ",
1182     O2S(objPtr)), Tcl_GetObjResult(interp));
1183     Tcl_DecrRefCount(objPtr);
1184     result = TCL_ERROR;
1185     goto checkForCatch;
1186     }
1187     PUSH_OBJECT(valuePtr);
1188     TRACE_WITH_OBJ(("\"%.30s\" => ", O2S(objPtr)), valuePtr);
1189     TclDecrRefCount(objPtr);
1190     ADJUST_PC(1);
1191    
1192     case INST_STORE_SCALAR4:
1193     opnd = TclGetUInt4AtPtr(pc+1);
1194     pcAdjustment = 5;
1195     goto doStoreScalar;
1196    
1197     case INST_STORE_SCALAR1:
1198     opnd = TclGetUInt1AtPtr(pc+1);
1199     pcAdjustment = 2;
1200    
1201     doStoreScalar:
1202     valuePtr = POP_OBJECT();
1203     DECACHE_STACK_INFO();
1204     value2Ptr = TclSetIndexedScalar(interp, opnd, valuePtr,
1205     /*leaveErrorMsg*/ 1);
1206     CACHE_STACK_INFO();
1207     if (value2Ptr == NULL) {
1208     TRACE_WITH_OBJ(("%u <- \"%.30s\" => ERROR: ",
1209     opnd, O2S(valuePtr)), Tcl_GetObjResult(interp));
1210     Tcl_DecrRefCount(valuePtr);
1211     result = TCL_ERROR;
1212     goto checkForCatch;
1213     }
1214     PUSH_OBJECT(value2Ptr);
1215     TRACE_WITH_OBJ(("%u <- \"%.30s\" => ",
1216     opnd, O2S(valuePtr)), value2Ptr);
1217     TclDecrRefCount(valuePtr);
1218     ADJUST_PC(pcAdjustment);
1219    
1220     case INST_STORE_SCALAR_STK:
1221     valuePtr = POP_OBJECT();
1222     objPtr = POP_OBJECT(); /* scalar name */
1223     DECACHE_STACK_INFO();
1224     value2Ptr = Tcl_ObjSetVar2(interp, objPtr, NULL, valuePtr,
1225     TCL_LEAVE_ERR_MSG);
1226     CACHE_STACK_INFO();
1227     if (value2Ptr == NULL) {
1228     TRACE_WITH_OBJ(("\"%.30s\" <- \"%.30s\" => ERROR: ",
1229     O2S(objPtr), O2S(valuePtr)),
1230     Tcl_GetObjResult(interp));
1231     Tcl_DecrRefCount(objPtr);
1232     Tcl_DecrRefCount(valuePtr);
1233     result = TCL_ERROR;
1234     goto checkForCatch;
1235     }
1236     PUSH_OBJECT(value2Ptr);
1237     TRACE_WITH_OBJ(("\"%.30s\" <- \"%.30s\" => ",
1238     O2S(objPtr), O2S(valuePtr)), value2Ptr);
1239     TclDecrRefCount(objPtr);
1240     TclDecrRefCount(valuePtr);
1241     ADJUST_PC(1);
1242    
1243     case INST_STORE_ARRAY4:
1244     opnd = TclGetUInt4AtPtr(pc+1);
1245     pcAdjustment = 5;
1246     goto doStoreArray;
1247    
1248     case INST_STORE_ARRAY1:
1249     opnd = TclGetUInt1AtPtr(pc+1);
1250     pcAdjustment = 2;
1251    
1252     doStoreArray:
1253     {
1254     Tcl_Obj *elemPtr;
1255    
1256     valuePtr = POP_OBJECT();
1257     elemPtr = POP_OBJECT();
1258     DECACHE_STACK_INFO();
1259     value2Ptr = TclSetElementOfIndexedArray(interp, opnd,
1260     elemPtr, valuePtr, TCL_LEAVE_ERR_MSG);
1261     CACHE_STACK_INFO();
1262     if (value2Ptr == NULL) {
1263     TRACE_WITH_OBJ(("%u \"%.30s\" <- \"%.30s\" => ERROR: ",
1264     opnd, O2S(elemPtr), O2S(valuePtr)),
1265     Tcl_GetObjResult(interp));
1266     Tcl_DecrRefCount(elemPtr);
1267     Tcl_DecrRefCount(valuePtr);
1268     result = TCL_ERROR;
1269     goto checkForCatch;
1270     }
1271     PUSH_OBJECT(value2Ptr);
1272     TRACE_WITH_OBJ(("%u \"%.30s\" <- \"%.30s\" => ",
1273     opnd, O2S(elemPtr), O2S(valuePtr)), value2Ptr);
1274     TclDecrRefCount(elemPtr);
1275     TclDecrRefCount(valuePtr);
1276     }
1277     ADJUST_PC(pcAdjustment);
1278    
1279     case INST_STORE_ARRAY_STK:
1280     {
1281     Tcl_Obj *elemPtr;
1282    
1283     valuePtr = POP_OBJECT();
1284     elemPtr = POP_OBJECT();
1285     objPtr = POP_OBJECT(); /* array name */
1286     DECACHE_STACK_INFO();
1287     value2Ptr = Tcl_ObjSetVar2(interp, objPtr, elemPtr, valuePtr,
1288     TCL_LEAVE_ERR_MSG);
1289     CACHE_STACK_INFO();
1290     if (value2Ptr == NULL) {
1291     TRACE_WITH_OBJ(("\"%.30s(%.30s)\" <- \"%.30s\" => ERROR: ",
1292     O2S(objPtr), O2S(elemPtr), O2S(valuePtr)),
1293     Tcl_GetObjResult(interp));
1294     Tcl_DecrRefCount(objPtr);
1295     Tcl_DecrRefCount(elemPtr);
1296     Tcl_DecrRefCount(valuePtr);
1297     result = TCL_ERROR;
1298     goto checkForCatch;
1299     }
1300     PUSH_OBJECT(value2Ptr);
1301     TRACE_WITH_OBJ(("\"%.30s(%.30s)\" <- \"%.30s\" => ",
1302     O2S(objPtr), O2S(elemPtr), O2S(valuePtr)),
1303     value2Ptr);
1304     TclDecrRefCount(objPtr);
1305     TclDecrRefCount(elemPtr);
1306     TclDecrRefCount(valuePtr);
1307     }
1308     ADJUST_PC(1);
1309    
1310     case INST_STORE_STK:
1311     valuePtr = POP_OBJECT();
1312     objPtr = POP_OBJECT(); /* variable name */
1313     DECACHE_STACK_INFO();
1314     value2Ptr = Tcl_ObjSetVar2(interp, objPtr, NULL, valuePtr,
1315     TCL_LEAVE_ERR_MSG);
1316     CACHE_STACK_INFO();
1317     if (value2Ptr == NULL) {
1318     TRACE_WITH_OBJ(("\"%.30s\" <- \"%.30s\" => ERROR: ",
1319     O2S(objPtr), O2S(valuePtr)),
1320     Tcl_GetObjResult(interp));
1321     Tcl_DecrRefCount(objPtr);
1322     Tcl_DecrRefCount(valuePtr);
1323     result = TCL_ERROR;
1324     goto checkForCatch;
1325     }
1326     PUSH_OBJECT(value2Ptr);
1327     TRACE_WITH_OBJ(("\"%.30s\" <- \"%.30s\" => ",
1328     O2S(objPtr), O2S(valuePtr)), value2Ptr);
1329     TclDecrRefCount(objPtr);
1330     TclDecrRefCount(valuePtr);
1331     ADJUST_PC(1);
1332    
1333     case INST_INCR_SCALAR1:
1334     opnd = TclGetUInt1AtPtr(pc+1);
1335     valuePtr = POP_OBJECT();
1336     if (valuePtr->typePtr != &tclIntType) {
1337     result = tclIntType.setFromAnyProc(interp, valuePtr);
1338     if (result != TCL_OK) {
1339     TRACE_WITH_OBJ(("%u (by %s) => ERROR converting increment amount to int: ",
1340     opnd, O2S(valuePtr)), Tcl_GetObjResult(interp));
1341     Tcl_DecrRefCount(valuePtr);
1342     goto checkForCatch;
1343     }
1344     }
1345     i = valuePtr->internalRep.longValue;
1346     DECACHE_STACK_INFO();
1347     value2Ptr = TclIncrIndexedScalar(interp, opnd, i);
1348     CACHE_STACK_INFO();
1349     if (value2Ptr == NULL) {
1350     TRACE_WITH_OBJ(("%u (by %ld) => ERROR: ", opnd, i),
1351     Tcl_GetObjResult(interp));
1352     Tcl_DecrRefCount(valuePtr);
1353     result = TCL_ERROR;
1354     goto checkForCatch;
1355     }
1356     PUSH_OBJECT(value2Ptr);
1357     TRACE_WITH_OBJ(("%u (by %ld) => ", opnd, i), value2Ptr);
1358     TclDecrRefCount(valuePtr);
1359     ADJUST_PC(2);
1360    
1361     case INST_INCR_SCALAR_STK:
1362     case INST_INCR_STK:
1363     valuePtr = POP_OBJECT();
1364     objPtr = POP_OBJECT(); /* scalar name */
1365     if (valuePtr->typePtr != &tclIntType) {
1366     result = tclIntType.setFromAnyProc(interp, valuePtr);
1367     if (result != TCL_OK) {
1368     TRACE_WITH_OBJ(("\"%.30s\" (by %s) => ERROR converting increment amount to int: ",
1369     O2S(objPtr), O2S(valuePtr)),
1370     Tcl_GetObjResult(interp));
1371     Tcl_DecrRefCount(objPtr);
1372     Tcl_DecrRefCount(valuePtr);
1373     goto checkForCatch;
1374     }
1375     }
1376     i = valuePtr->internalRep.longValue;
1377     DECACHE_STACK_INFO();
1378     value2Ptr = TclIncrVar2(interp, objPtr, (Tcl_Obj *) NULL, i,
1379     TCL_LEAVE_ERR_MSG);
1380     CACHE_STACK_INFO();
1381     if (value2Ptr == NULL) {
1382     TRACE_WITH_OBJ(("\"%.30s\" (by %ld) => ERROR: ",
1383     O2S(objPtr), i), Tcl_GetObjResult(interp));
1384     Tcl_DecrRefCount(objPtr);
1385     Tcl_DecrRefCount(valuePtr);
1386     result = TCL_ERROR;
1387     goto checkForCatch;
1388     }
1389     PUSH_OBJECT(value2Ptr);
1390     TRACE_WITH_OBJ(("\"%.30s\" (by %ld) => ", O2S(objPtr), i),
1391     value2Ptr);
1392     Tcl_DecrRefCount(objPtr);
1393     Tcl_DecrRefCount(valuePtr);
1394     ADJUST_PC(1);
1395    
1396     case INST_INCR_ARRAY1:
1397     {
1398     Tcl_Obj *elemPtr;
1399    
1400     opnd = TclGetUInt1AtPtr(pc+1);
1401     valuePtr = POP_OBJECT();
1402     elemPtr = POP_OBJECT();
1403     if (valuePtr->typePtr != &tclIntType) {
1404     result = tclIntType.setFromAnyProc(interp, valuePtr);
1405     if (result != TCL_OK) {
1406     TRACE_WITH_OBJ(("%u \"%.30s\" (by %s) => ERROR converting increment amount to int: ",
1407     opnd, O2S(elemPtr), O2S(valuePtr)),
1408     Tcl_GetObjResult(interp));
1409     Tcl_DecrRefCount(elemPtr);
1410     Tcl_DecrRefCount(valuePtr);
1411     goto checkForCatch;
1412     }
1413     }
1414     i = valuePtr->internalRep.longValue;
1415     DECACHE_STACK_INFO();
1416     value2Ptr = TclIncrElementOfIndexedArray(interp, opnd,
1417     elemPtr, i);
1418     CACHE_STACK_INFO();
1419     if (value2Ptr == NULL) {
1420     TRACE_WITH_OBJ(("%u \"%.30s\" (by %ld) => ERROR: ",
1421     opnd, O2S(elemPtr), i),
1422     Tcl_GetObjResult(interp));
1423     Tcl_DecrRefCount(elemPtr);
1424     Tcl_DecrRefCount(valuePtr);
1425     result = TCL_ERROR;
1426     goto checkForCatch;
1427     }
1428     PUSH_OBJECT(value2Ptr);
1429     TRACE_WITH_OBJ(("%u \"%.30s\" (by %ld) => ",
1430     opnd, O2S(elemPtr), i), value2Ptr);
1431     Tcl_DecrRefCount(elemPtr);
1432     Tcl_DecrRefCount(valuePtr);
1433     }
1434     ADJUST_PC(2);
1435    
1436     case INST_INCR_ARRAY_STK:
1437     {
1438     Tcl_Obj *elemPtr;
1439    
1440     valuePtr = POP_OBJECT();
1441     elemPtr = POP_OBJECT();
1442     objPtr = POP_OBJECT(); /* array name */
1443     if (valuePtr->typePtr != &tclIntType) {
1444     result = tclIntType.setFromAnyProc(interp, valuePtr);
1445     if (result != TCL_OK) {
1446     TRACE_WITH_OBJ(("\"%.30s(%.30s)\" (by %s) => ERROR converting increment amount to int: ",
1447     O2S(objPtr), O2S(elemPtr), O2S(valuePtr)),
1448     Tcl_GetObjResult(interp));
1449     Tcl_DecrRefCount(objPtr);
1450     Tcl_DecrRefCount(elemPtr);
1451     Tcl_DecrRefCount(valuePtr);
1452     goto checkForCatch;
1453     }
1454     }
1455     i = valuePtr->internalRep.longValue;
1456     DECACHE_STACK_INFO();
1457     value2Ptr = TclIncrVar2(interp, objPtr, elemPtr, i,
1458     TCL_LEAVE_ERR_MSG);
1459     CACHE_STACK_INFO();
1460     if (value2Ptr == NULL) {
1461     TRACE_WITH_OBJ(("\"%.30s(%.30s)\" (by %ld) => ERROR: ",
1462     O2S(objPtr), O2S(elemPtr), i),
1463     Tcl_GetObjResult(interp));
1464     Tcl_DecrRefCount(objPtr);
1465     Tcl_DecrRefCount(elemPtr);
1466     Tcl_DecrRefCount(valuePtr);
1467     result = TCL_ERROR;
1468     goto checkForCatch;
1469     }
1470     PUSH_OBJECT(value2Ptr);
1471     TRACE_WITH_OBJ(("\"%.30s(%.30s)\" (by %ld) => ",
1472     O2S(objPtr), O2S(elemPtr), i), value2Ptr);
1473     Tcl_DecrRefCount(objPtr);
1474     Tcl_DecrRefCount(elemPtr);
1475     Tcl_DecrRefCount(valuePtr);
1476     }
1477     ADJUST_PC(1);
1478    
1479     case INST_INCR_SCALAR1_IMM:
1480     opnd = TclGetUInt1AtPtr(pc+1);
1481     i = TclGetInt1AtPtr(pc+2);
1482     DECACHE_STACK_INFO();
1483     value2Ptr = TclIncrIndexedScalar(interp, opnd, i);
1484     CACHE_STACK_INFO();
1485     if (value2Ptr == NULL) {
1486     TRACE_WITH_OBJ(("%u %ld => ERROR: ", opnd, i),
1487     Tcl_GetObjResult(interp));
1488     result = TCL_ERROR;
1489     goto checkForCatch;
1490     }
1491     PUSH_OBJECT(value2Ptr);
1492     TRACE_WITH_OBJ(("%u %ld => ", opnd, i), value2Ptr);
1493     ADJUST_PC(3);
1494    
1495     case INST_INCR_SCALAR_STK_IMM:
1496     case INST_INCR_STK_IMM:
1497     objPtr = POP_OBJECT(); /* variable name */
1498     i = TclGetInt1AtPtr(pc+1);
1499     DECACHE_STACK_INFO();
1500     value2Ptr = TclIncrVar2(interp, objPtr, (Tcl_Obj *) NULL, i,
1501     TCL_LEAVE_ERR_MSG);
1502     CACHE_STACK_INFO();
1503     if (value2Ptr == NULL) {
1504     TRACE_WITH_OBJ(("\"%.30s\" %ld => ERROR: ",
1505     O2S(objPtr), i), Tcl_GetObjResult(interp));
1506     result = TCL_ERROR;
1507     Tcl_DecrRefCount(objPtr);
1508     goto checkForCatch;
1509     }
1510     PUSH_OBJECT(value2Ptr);
1511     TRACE_WITH_OBJ(("\"%.30s\" %ld => ", O2S(objPtr), i),
1512     value2Ptr);
1513     TclDecrRefCount(objPtr);
1514     ADJUST_PC(2);
1515    
1516     case INST_INCR_ARRAY1_IMM:
1517     {
1518     Tcl_Obj *elemPtr;
1519    
1520     opnd = TclGetUInt1AtPtr(pc+1);
1521     i = TclGetInt1AtPtr(pc+2);
1522     elemPtr = POP_OBJECT();
1523     DECACHE_STACK_INFO();
1524     value2Ptr = TclIncrElementOfIndexedArray(interp, opnd,
1525     elemPtr, i);
1526     CACHE_STACK_INFO();
1527     if (value2Ptr == NULL) {
1528     TRACE_WITH_OBJ(("%u \"%.30s\" (by %ld) => ERROR: ",
1529     opnd, O2S(elemPtr), i),
1530     Tcl_GetObjResult(interp));
1531     Tcl_DecrRefCount(elemPtr);
1532     result = TCL_ERROR;
1533     goto checkForCatch;
1534     }
1535     PUSH_OBJECT(value2Ptr);
1536     TRACE_WITH_OBJ(("%u \"%.30s\" (by %ld) => ",
1537     opnd, O2S(elemPtr), i), value2Ptr);
1538     Tcl_DecrRefCount(elemPtr);
1539     }
1540     ADJUST_PC(3);
1541    
1542     case INST_INCR_ARRAY_STK_IMM:
1543     {
1544     Tcl_Obj *elemPtr;
1545    
1546     i = TclGetInt1AtPtr(pc+1);
1547     elemPtr = POP_OBJECT();
1548     objPtr = POP_OBJECT(); /* array name */
1549     DECACHE_STACK_INFO();
1550     value2Ptr = TclIncrVar2(interp, objPtr, elemPtr, i,
1551     TCL_LEAVE_ERR_MSG);
1552     CACHE_STACK_INFO();
1553     if (value2Ptr == NULL) {
1554     TRACE_WITH_OBJ(("\"%.30s(%.30s)\" (by %ld) => ERROR: ",
1555     O2S(objPtr), O2S(elemPtr), i),
1556     Tcl_GetObjResult(interp));
1557     Tcl_DecrRefCount(objPtr);
1558     Tcl_DecrRefCount(elemPtr);
1559     result = TCL_ERROR;
1560     goto checkForCatch;
1561     }
1562     PUSH_OBJECT(value2Ptr);
1563     TRACE_WITH_OBJ(("\"%.30s(%.30s)\" (by %ld) => ",
1564     O2S(objPtr), O2S(elemPtr), i), value2Ptr);
1565     Tcl_DecrRefCount(objPtr);
1566     Tcl_DecrRefCount(elemPtr);
1567     }
1568     ADJUST_PC(2);
1569    
1570     case INST_JUMP1:
1571     #ifdef TCL_COMPILE_DEBUG
1572     opnd = TclGetInt1AtPtr(pc+1);
1573     TRACE(("%d => new pc %u\n", opnd,
1574     (unsigned int)(pc + opnd - codePtr->codeStart)));
1575     pc += opnd;
1576     #else
1577     pc += TclGetInt1AtPtr(pc+1);
1578     #endif /* TCL_COMPILE_DEBUG */
1579     continue;
1580    
1581     case INST_JUMP4:
1582     opnd = TclGetInt4AtPtr(pc+1);
1583     TRACE(("%d => new pc %u\n", opnd,
1584     (unsigned int)(pc + opnd - codePtr->codeStart)));
1585     ADJUST_PC(opnd);
1586    
1587     case INST_JUMP_TRUE4:
1588     opnd = TclGetInt4AtPtr(pc+1);
1589     pcAdjustment = 5;
1590     goto doJumpTrue;
1591    
1592     case INST_JUMP_TRUE1:
1593     opnd = TclGetInt1AtPtr(pc+1);
1594     pcAdjustment = 2;
1595    
1596     doJumpTrue:
1597     {
1598     int b;
1599    
1600     valuePtr = POP_OBJECT();
1601     if (valuePtr->typePtr == &tclIntType) {
1602     b = (valuePtr->internalRep.longValue != 0);
1603     } else if (valuePtr->typePtr == &tclDoubleType) {
1604     b = (valuePtr->internalRep.doubleValue != 0.0);
1605     } else {
1606     result = Tcl_GetBooleanFromObj(interp, valuePtr, &b);
1607     if (result != TCL_OK) {
1608     TRACE_WITH_OBJ(("%d => ERROR: ", opnd),
1609     Tcl_GetObjResult(interp));
1610     Tcl_DecrRefCount(valuePtr);
1611     goto checkForCatch;
1612     }
1613     }
1614     if (b) {
1615     TRACE(("%d => %.20s true, new pc %u\n",
1616     opnd, O2S(valuePtr),
1617     (unsigned int)(pc+opnd - codePtr->codeStart)));
1618     TclDecrRefCount(valuePtr);
1619     ADJUST_PC(opnd);
1620     } else {
1621     TRACE(("%d => %.20s false\n", opnd, O2S(valuePtr)));
1622     TclDecrRefCount(valuePtr);
1623     ADJUST_PC(pcAdjustment);
1624     }
1625     }
1626    
1627     case INST_JUMP_FALSE4:
1628     opnd = TclGetInt4AtPtr(pc+1);
1629     pcAdjustment = 5;
1630     goto doJumpFalse;
1631    
1632     case INST_JUMP_FALSE1:
1633     opnd = TclGetInt1AtPtr(pc+1);
1634     pcAdjustment = 2;
1635    
1636     doJumpFalse:
1637     {
1638     int b;
1639    
1640     valuePtr = POP_OBJECT();
1641     if (valuePtr->typePtr == &tclIntType) {
1642     b = (valuePtr->internalRep.longValue != 0);
1643     } else if (valuePtr->typePtr == &tclDoubleType) {
1644     b = (valuePtr->internalRep.doubleValue != 0.0);
1645     } else {
1646     result = Tcl_GetBooleanFromObj(interp, valuePtr, &b);
1647     if (result != TCL_OK) {
1648     TRACE_WITH_OBJ(("%d => ERROR: ", opnd),
1649     Tcl_GetObjResult(interp));
1650     Tcl_DecrRefCount(valuePtr);
1651     goto checkForCatch;
1652     }
1653     }
1654     if (b) {
1655     TRACE(("%d => %.20s true\n", opnd, O2S(valuePtr)));
1656     TclDecrRefCount(valuePtr);
1657     ADJUST_PC(pcAdjustment);
1658     } else {
1659     TRACE(("%d => %.20s false, new pc %u\n",
1660     opnd, O2S(valuePtr),
1661     (unsigned int)(pc + opnd - codePtr->codeStart)));
1662     TclDecrRefCount(valuePtr);
1663     ADJUST_PC(opnd);
1664     }
1665     }
1666    
1667     case INST_LOR:
1668     case INST_LAND:
1669     {
1670     /*
1671     * Operands must be boolean or numeric. No int->double
1672     * conversions are performed.
1673     */
1674    
1675     int i1, i2;
1676     int iResult;
1677     char *s;
1678     Tcl_ObjType *t1Ptr, *t2Ptr;
1679    
1680     value2Ptr = POP_OBJECT();
1681     valuePtr = POP_OBJECT();
1682     t1Ptr = valuePtr->typePtr;
1683     t2Ptr = value2Ptr->typePtr;
1684    
1685     if ((t1Ptr == &tclIntType) || (t1Ptr == &tclBooleanType)) {
1686     i1 = (valuePtr->internalRep.longValue != 0);
1687     } else if (t1Ptr == &tclDoubleType) {
1688     i1 = (valuePtr->internalRep.doubleValue != 0.0);
1689     } else {
1690     s = Tcl_GetStringFromObj(valuePtr, &length);
1691     if (TclLooksLikeInt(s, length)) {
1692     result = Tcl_GetLongFromObj((Tcl_Interp *) NULL,
1693     valuePtr, &i);
1694     i1 = (i != 0);
1695     } else {
1696     result = Tcl_GetBooleanFromObj((Tcl_Interp *) NULL,
1697     valuePtr, &i1);
1698     i1 = (i1 != 0);
1699     }
1700     if (result != TCL_OK) {
1701     TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n",
1702     O2S(valuePtr),
1703     (t1Ptr? t1Ptr->name : "null")));
1704     IllegalExprOperandType(interp, pc, valuePtr);
1705     Tcl_DecrRefCount(valuePtr);
1706     Tcl_DecrRefCount(value2Ptr);
1707     goto checkForCatch;
1708     }
1709     }
1710    
1711     if ((t2Ptr == &tclIntType) || (t2Ptr == &tclBooleanType)) {
1712     i2 = (value2Ptr->internalRep.longValue != 0);
1713     } else if (t2Ptr == &tclDoubleType) {
1714     i2 = (value2Ptr->internalRep.doubleValue != 0.0);
1715     } else {
1716     s = Tcl_GetStringFromObj(value2Ptr, &length);
1717     if (TclLooksLikeInt(s, length)) {
1718     result = Tcl_GetLongFromObj((Tcl_Interp *) NULL,
1719     value2Ptr, &i);
1720     i2 = (i != 0);
1721     } else {
1722     result = Tcl_GetBooleanFromObj((Tcl_Interp *) NULL,
1723     value2Ptr, &i2);
1724     }
1725     if (result != TCL_OK) {
1726     TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n",
1727     O2S(value2Ptr),
1728     (t2Ptr? t2Ptr->name : "null")));
1729     IllegalExprOperandType(interp, pc, value2Ptr);
1730     Tcl_DecrRefCount(valuePtr);
1731     Tcl_DecrRefCount(value2Ptr);
1732     goto checkForCatch;
1733     }
1734     }
1735    
1736     /*
1737     * Reuse the valuePtr object already on stack if possible.
1738     */
1739    
1740     if (*pc == INST_LOR) {
1741     iResult = (i1 || i2);
1742     } else {
1743     iResult = (i1 && i2);
1744     }
1745     if (Tcl_IsShared(valuePtr)) {
1746     PUSH_OBJECT(Tcl_NewLongObj(iResult));
1747     TRACE(("%.20s %.20s => %d\n",
1748     O2S(valuePtr), O2S(value2Ptr), iResult));
1749     TclDecrRefCount(valuePtr);
1750     } else { /* reuse the valuePtr object */
1751     TRACE(("%.20s %.20s => %d\n",
1752     O2S(valuePtr), O2S(value2Ptr), iResult));
1753     Tcl_SetLongObj(valuePtr, iResult);
1754     ++stackTop; /* valuePtr now on stk top has right r.c. */
1755     }
1756     TclDecrRefCount(value2Ptr);
1757     }
1758     ADJUST_PC(1);
1759    
1760     case INST_EQ:
1761     case INST_NEQ:
1762     case INST_LT:
1763     case INST_GT:
1764     case INST_LE:
1765     case INST_GE:
1766     {
1767     /*
1768     * Any type is allowed but the two operands must have the
1769     * same type. We will compute value op value2.
1770     */
1771    
1772     Tcl_ObjType *t1Ptr, *t2Ptr;
1773     char *s1 = NULL; /* Init. avoids compiler warning. */
1774     char *s2 = NULL; /* Init. avoids compiler warning. */
1775     long i2 = 0; /* Init. avoids compiler warning. */
1776     double d1 = 0.0; /* Init. avoids compiler warning. */
1777     double d2 = 0.0; /* Init. avoids compiler warning. */
1778     long iResult = 0; /* Init. avoids compiler warning. */
1779    
1780     value2Ptr = POP_OBJECT();
1781     valuePtr = POP_OBJECT();
1782     t1Ptr = valuePtr->typePtr;
1783     t2Ptr = value2Ptr->typePtr;
1784    
1785     /*
1786     * We only want to coerce numeric validation if
1787     * neither type is NULL. A NULL type means the arg is
1788     * essentially an empty object ("", {} or [list]).
1789     */
1790     if (!((((t1Ptr == NULL) && (valuePtr->bytes == NULL))
1791     || (valuePtr->bytes && (valuePtr->length == 0)))
1792     || (((t2Ptr == NULL) && (value2Ptr->bytes == NULL))
1793     || (value2Ptr->bytes && (value2Ptr->length == 0))))) {
1794     if ((t1Ptr != &tclIntType) && (t1Ptr != &tclDoubleType)) {
1795     s1 = Tcl_GetStringFromObj(valuePtr, &length);
1796     if (TclLooksLikeInt(s1, length)) {
1797     (void) Tcl_GetLongFromObj((Tcl_Interp *) NULL,
1798     valuePtr, &i);
1799     } else {
1800     (void) Tcl_GetDoubleFromObj((Tcl_Interp *) NULL,
1801     valuePtr, &d1);
1802     }
1803     t1Ptr = valuePtr->typePtr;
1804     }
1805     if ((t2Ptr != &tclIntType) && (t2Ptr != &tclDoubleType)) {
1806     s2 = Tcl_GetStringFromObj(value2Ptr, &length);
1807     if (TclLooksLikeInt(s2, length)) {
1808     (void) Tcl_GetLongFromObj((Tcl_Interp *) NULL,
1809     value2Ptr, &i2);
1810     } else {
1811     (void) Tcl_GetDoubleFromObj((Tcl_Interp *) NULL,
1812     value2Ptr, &d2);
1813     }
1814     t2Ptr = value2Ptr->typePtr;
1815     }
1816     }
1817     if (((t1Ptr != &tclIntType) && (t1Ptr != &tclDoubleType))
1818     || ((t2Ptr != &tclIntType) && (t2Ptr != &tclDoubleType))) {
1819     /*
1820     * One operand is not numeric. Compare as strings.
1821     */
1822     int cmpValue;
1823     s1 = Tcl_GetString(valuePtr);
1824     s2 = Tcl_GetString(value2Ptr);
1825     cmpValue = strcmp(s1, s2);
1826     switch (*pc) {
1827     case INST_EQ:
1828     iResult = (cmpValue == 0);
1829     break;
1830     case INST_NEQ:
1831     iResult = (cmpValue != 0);
1832     break;
1833     case INST_LT:
1834     iResult = (cmpValue < 0);
1835     break;
1836     case INST_GT:
1837     iResult = (cmpValue > 0);
1838     break;
1839     case INST_LE:
1840     iResult = (cmpValue <= 0);
1841     break;
1842     case INST_GE:
1843     iResult = (cmpValue >= 0);
1844     break;
1845     }
1846     } else if ((t1Ptr == &tclDoubleType)
1847     || (t2Ptr == &tclDoubleType)) {
1848     /*
1849     * Compare as doubles.
1850     */
1851     if (t1Ptr == &tclDoubleType) {
1852     d1 = valuePtr->internalRep.doubleValue;
1853     if (t2Ptr == &tclIntType) {
1854     d2 = value2Ptr->internalRep.longValue;
1855     } else {
1856     d2 = value2Ptr->internalRep.doubleValue;
1857     }
1858     } else { /* t1Ptr is int, t2Ptr is double */
1859     d1 = valuePtr->internalRep.longValue;
1860     d2 = value2Ptr->internalRep.doubleValue;
1861     }
1862     switch (*pc) {
1863     case INST_EQ:
1864     iResult = d1 == d2;
1865     break;
1866     case INST_NEQ:
1867     iResult = d1 != d2;
1868     break;
1869     case INST_LT:
1870     iResult = d1 < d2;
1871     break;
1872     case INST_GT:
1873     iResult = d1 > d2;
1874     break;
1875     case INST_LE:
1876     iResult = d1 <= d2;
1877     break;
1878     case INST_GE:
1879     iResult = d1 >= d2;
1880     break;
1881     }
1882     } else {
1883     /*
1884     * Compare as ints.
1885     */
1886     i = valuePtr->internalRep.longValue;
1887     i2 = value2Ptr->internalRep.longValue;
1888     switch (*pc) {
1889     case INST_EQ:
1890     iResult = i == i2;
1891     break;
1892     case INST_NEQ:
1893     iResult = i != i2;
1894     break;
1895     case INST_LT:
1896     iResult = i < i2;
1897     break;
1898     case INST_GT:
1899     iResult = i > i2;
1900     break;
1901     case INST_LE:
1902     iResult = i <= i2;
1903     break;
1904     case INST_GE:
1905     iResult = i >= i2;
1906     break;
1907     }
1908     }
1909    
1910     /*
1911     * Reuse the valuePtr object already on stack if possible.
1912     */
1913    
1914     if (Tcl_IsShared(valuePtr)) {
1915     PUSH_OBJECT(Tcl_NewLongObj(iResult));
1916     TRACE(("%.20s %.20s => %ld\n",
1917     O2S(valuePtr), O2S(value2Ptr), iResult));
1918     TclDecrRefCount(valuePtr);
1919     } else { /* reuse the valuePtr object */
1920     TRACE(("%.20s %.20s => %ld\n",
1921     O2S(valuePtr), O2S(value2Ptr), iResult));
1922     Tcl_SetLongObj(valuePtr, iResult);
1923     ++stackTop; /* valuePtr now on stk top has right r.c. */
1924     }
1925     TclDecrRefCount(value2Ptr);
1926     }
1927     ADJUST_PC(1);
1928    
1929     case INST_MOD:
1930     case INST_LSHIFT:
1931     case INST_RSHIFT:
1932     case INST_BITOR:
1933     case INST_BITXOR:
1934     case INST_BITAND:
1935     {
1936     /*
1937     * Only integers are allowed. We compute value op value2.
1938     */
1939    
1940     long i2, rem, negative;
1941     long iResult = 0; /* Init. avoids compiler warning. */
1942    
1943     value2Ptr = POP_OBJECT();
1944     valuePtr = POP_OBJECT();
1945     if (valuePtr->typePtr == &tclIntType) {
1946     i = valuePtr->internalRep.longValue;
1947     } else { /* try to convert to int */
1948     result = Tcl_GetLongFromObj((Tcl_Interp *) NULL,
1949     valuePtr, &i);
1950     if (result != TCL_OK) {
1951     TRACE(("%.20s %.20s => ILLEGAL 1st TYPE %s\n",
1952     O2S(valuePtr), O2S(value2Ptr),
1953     (valuePtr->typePtr?
1954     valuePtr->typePtr->name : "null")));
1955     IllegalExprOperandType(interp, pc, valuePtr);
1956     Tcl_DecrRefCount(valuePtr);
1957     Tcl_DecrRefCount(value2Ptr);
1958     goto checkForCatch;
1959     }
1960     }
1961     if (value2Ptr->typePtr == &tclIntType) {
1962     i2 = value2Ptr->internalRep.longValue;
1963     } else {
1964     result = Tcl_GetLongFromObj((Tcl_Interp *) NULL,
1965     value2Ptr, &i2);
1966     if (result != TCL_OK) {
1967     TRACE(("%.20s %.20s => ILLEGAL 2nd TYPE %s\n",
1968     O2S(valuePtr), O2S(value2Ptr),
1969     (value2Ptr->typePtr?
1970     value2Ptr->typePtr->name : "null")));
1971     IllegalExprOperandType(interp, pc, value2Ptr);
1972     Tcl_DecrRefCount(valuePtr);
1973     Tcl_DecrRefCount(value2Ptr);
1974     goto checkForCatch;
1975     }
1976     }
1977    
1978     switch (*pc) {
1979     case INST_MOD:
1980     /*
1981     * This code is tricky: C doesn't guarantee much about
1982     * the quotient or remainder, but Tcl does. The
1983     * remainder always has the same sign as the divisor and
1984     * a smaller absolute value.
1985     */
1986     if (i2 == 0) {
1987     TRACE(("%ld %ld => DIVIDE BY ZERO\n", i, i2));
1988     Tcl_DecrRefCount(valuePtr);
1989     Tcl_DecrRefCount(value2Ptr);
1990     goto divideByZero;
1991     }
1992     negative = 0;
1993     if (i2 < 0) {
1994     i2 = -i2;
1995     i = -i;
1996     negative = 1;
1997     }
1998     rem = i % i2;
1999     if (rem < 0) {
2000     rem += i2;
2001     }
2002     if (negative) {
2003     rem = -rem;
2004     }
2005     iResult = rem;
2006     break;
2007     case INST_LSHIFT:
2008     iResult = i << i2;
2009     break;
2010     case INST_RSHIFT:
2011     /*
2012     * The following code is a bit tricky: it ensures that
2013     * right shifts propagate the sign bit even on machines
2014     * where ">>" won't do it by default.
2015     */
2016     if (i < 0) {
2017     iResult = ~((~i) >> i2);
2018     } else {
2019     iResult = i >> i2;
2020     }
2021     break;
2022     case INST_BITOR:
2023     iResult = i | i2;
2024     break;
2025     case INST_BITXOR:
2026     iResult = i ^ i2;
2027     break;
2028     case INST_BITAND:
2029     iResult = i & i2;
2030     break;
2031     }
2032    
2033     /*
2034     * Reuse the valuePtr object already on stack if possible.
2035     */
2036    
2037     if (Tcl_IsShared(valuePtr)) {
2038     PUSH_OBJECT(Tcl_NewLongObj(iResult));
2039     TRACE(("%ld %ld => %ld\n", i, i2, iResult));
2040     TclDecrRefCount(valuePtr);
2041     } else { /* reuse the valuePtr object */
2042     TRACE(("%ld %ld => %ld\n", i, i2, iResult));
2043     Tcl_SetLongObj(valuePtr, iResult);
2044     ++stackTop; /* valuePtr now on stk top has right r.c. */
2045     }
2046     TclDecrRefCount(value2Ptr);
2047     }
2048     ADJUST_PC(1);
2049    
2050     case INST_ADD:
2051     case INST_SUB:
2052     case INST_MULT:
2053     case INST_DIV:
2054     {
2055     /*
2056     * Operands must be numeric and ints get converted to floats
2057     * if necessary. We compute value op value2.
2058     */
2059    
2060     Tcl_ObjType *t1Ptr, *t2Ptr;
2061     long i2, quot, rem;
2062     double d1, d2;
2063     long iResult = 0; /* Init. avoids compiler warning. */
2064     double dResult = 0.0; /* Init. avoids compiler warning. */
2065     int doDouble = 0; /* 1 if doing floating arithmetic */
2066    
2067     value2Ptr = POP_OBJECT();
2068     valuePtr = POP_OBJECT();
2069     t1Ptr = valuePtr->typePtr;
2070     t2Ptr = value2Ptr->typePtr;
2071    
2072     if (t1Ptr == &tclIntType) {
2073     i = valuePtr->internalRep.longValue;
2074     } else if ((t1Ptr == &tclDoubleType)
2075     && (valuePtr->bytes == NULL)) {
2076     /*
2077     * We can only use the internal rep directly if there is
2078     * no string rep. Otherwise the string rep might actually
2079     * look like an integer, which is preferred.
2080     */
2081    
2082     d1 = valuePtr->internalRep.doubleValue;
2083     } else {
2084     char *s = Tcl_GetStringFromObj(valuePtr, &length);
2085     if (TclLooksLikeInt(s, length)) {
2086     result = Tcl_GetLongFromObj((Tcl_Interp *) NULL,
2087     valuePtr, &i);
2088     } else {
2089     result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL,
2090     valuePtr, &d1);
2091     }
2092     if (result != TCL_OK) {
2093     TRACE(("%.20s %.20s => ILLEGAL 1st TYPE %s\n",
2094     s, O2S(valuePtr),
2095     (valuePtr->typePtr?
2096     valuePtr->typePtr->name : "null")));
2097     IllegalExprOperandType(interp, pc, valuePtr);
2098     Tcl_DecrRefCount(valuePtr);
2099     Tcl_DecrRefCount(value2Ptr);
2100     goto checkForCatch;
2101     }
2102     t1Ptr = valuePtr->typePtr;
2103     }
2104    
2105     if (t2Ptr == &tclIntType) {
2106     i2 = value2Ptr->internalRep.longValue;
2107     } else if ((t2Ptr == &tclDoubleType)
2108     && (value2Ptr->bytes == NULL)) {
2109     /*
2110     * We can only use the internal rep directly if there is
2111     * no string rep. Otherwise the string rep might actually
2112     * look like an integer, which is preferred.
2113     */
2114    
2115     d2 = value2Ptr->internalRep.doubleValue;
2116     } else {
2117     char *s = Tcl_GetStringFromObj(value2Ptr, &length);
2118     if (TclLooksLikeInt(s, length)) {
2119     result = Tcl_GetLongFromObj((Tcl_Interp *) NULL,
2120     value2Ptr, &i2);
2121     } else {
2122     result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL,
2123     value2Ptr, &d2);
2124     }
2125     if (result != TCL_OK) {
2126     TRACE(("%.20s %.20s => ILLEGAL 2nd TYPE %s\n",
2127     O2S(value2Ptr), s,
2128     (value2Ptr->typePtr?
2129     value2Ptr->typePtr->name : "null")));
2130     IllegalExprOperandType(interp, pc, value2Ptr);
2131     Tcl_DecrRefCount(valuePtr);
2132     Tcl_DecrRefCount(value2Ptr);
2133     goto checkForCatch;
2134     }
2135     t2Ptr = value2Ptr->typePtr;
2136     }
2137    
2138     if ((t1Ptr == &tclDoubleType) || (t2Ptr == &tclDoubleType)) {
2139     /*
2140     * Do double arithmetic.
2141     */
2142     doDouble = 1;
2143     if (t1Ptr == &tclIntType) {
2144     d1 = i; /* promote value 1 to double */
2145     } else if (t2Ptr == &tclIntType) {
2146     d2 = i2; /* promote value 2 to double */
2147     }
2148     switch (*pc) {
2149     case INST_ADD:
2150     dResult = d1 + d2;
2151     break;
2152     case INST_SUB:
2153     dResult = d1 - d2;
2154     break;
2155     case INST_MULT:
2156     dResult = d1 * d2;
2157     break;
2158     case INST_DIV:
2159     if (d2 == 0.0) {
2160     TRACE(("%.6g %.6g => DIVIDE BY ZERO\n", d1, d2));
2161     Tcl_DecrRefCount(valuePtr);
2162     Tcl_DecrRefCount(value2Ptr);
2163     goto divideByZero;
2164     }
2165     dResult = d1 / d2;
2166     break;
2167     }
2168    
2169     /*
2170     * Check now for IEEE floating-point error.
2171     */
2172    
2173     if (IS_NAN(dResult) || IS_INF(dResult)) {
2174     TRACE(("%.20s %.20s => IEEE FLOATING PT ERROR\n",
2175     O2S(valuePtr), O2S(value2Ptr)));
2176     TclExprFloatError(interp, dResult);
2177     result = TCL_ERROR;
2178     Tcl_DecrRefCount(valuePtr);
2179     Tcl_DecrRefCount(value2Ptr);
2180     goto checkForCatch;
2181     }
2182     } else {
2183     /*
2184     * Do integer arithmetic.
2185     */
2186     switch (*pc) {
2187     case INST_ADD:
2188     iResult = i + i2;
2189     break;
2190     case INST_SUB:
2191     iResult = i - i2;
2192     break;
2193     case INST_MULT:
2194     iResult = i * i2;
2195     break;
2196     case INST_DIV:
2197     /*
2198     * This code is tricky: C doesn't guarantee much
2199     * about the quotient or remainder, but Tcl does.
2200     * The remainder always has the same sign as the
2201     * divisor and a smaller absolute value.
2202     */
2203     if (i2 == 0) {
2204     TRACE(("%ld %ld => DIVIDE BY ZERO\n", i, i2));
2205     Tcl_DecrRefCount(valuePtr);
2206     Tcl_DecrRefCount(value2Ptr);
2207     goto divideByZero;
2208     }
2209     if (i2 < 0) {
2210     i2 = -i2;
2211     i = -i;
2212     }
2213     quot = i / i2;
2214     rem = i % i2;
2215     if (rem < 0) {
2216     quot -= 1;
2217     }
2218     iResult = quot;
2219     break;
2220     }
2221     }
2222    
2223     /*
2224     * Reuse the valuePtr object already on stack if possible.
2225     */
2226    
2227     if (Tcl_IsShared(valuePtr)) {
2228     if (doDouble) {
2229     PUSH_OBJECT(Tcl_NewDoubleObj(dResult));
2230     TRACE(("%.6g %.6g => %.6g\n", d1, d2, dResult));
2231     } else {
2232     PUSH_OBJECT(Tcl_NewLongObj(iResult));
2233     TRACE(("%ld %ld => %ld\n", i, i2, iResult));
2234     }
2235     TclDecrRefCount(valuePtr);
2236     } else { /* reuse the valuePtr object */
2237     if (doDouble) { /* NB: stack top is off by 1 */
2238     TRACE(("%.6g %.6g => %.6g\n", d1, d2, dResult));
2239     Tcl_SetDoubleObj(valuePtr, dResult);
2240     } else {
2241     TRACE(("%ld %ld => %ld\n", i, i2, iResult));
2242     Tcl_SetLongObj(valuePtr, iResult);
2243     }
2244     ++stackTop; /* valuePtr now on stk top has right r.c. */
2245     }
2246     TclDecrRefCount(value2Ptr);
2247     }
2248     ADJUST_PC(1);
2249    
2250     case INST_UPLUS:
2251     {
2252     /*
2253     * Operand must be numeric.
2254     */
2255    
2256     double d;
2257     Tcl_ObjType *tPtr;
2258    
2259     valuePtr = stackPtr[stackTop];
2260     tPtr = valuePtr->typePtr;
2261     if ((tPtr != &tclIntType) && ((tPtr != &tclDoubleType)
2262     || (valuePtr->bytes != NULL))) {
2263     char *s = Tcl_GetStringFromObj(valuePtr, &length);
2264     if (TclLooksLikeInt(s, length)) {
2265     result = Tcl_GetLongFromObj((Tcl_Interp *) NULL,
2266     valuePtr, &i);
2267     } else {
2268     result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL,
2269     valuePtr, &d);
2270     }
2271     if (result != TCL_OK) {
2272     TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n",
2273     s, (tPtr? tPtr->name : "null")));
2274     IllegalExprOperandType(interp, pc, valuePtr);
2275     goto checkForCatch;
2276     }
2277     tPtr = valuePtr->typePtr;
2278     }
2279    
2280     /*
2281     * Ensure that the operand's string rep is the same as the
2282     * formatted version of its internal rep. This makes sure
2283     * that "expr +000123" yields "83", not "000123". We
2284     * implement this by _discarding_ the string rep since we
2285     * know it will be regenerated, if needed later, by
2286     * formatting the internal rep's value.
2287     */
2288    
2289     if (Tcl_IsShared(valuePtr)) {
2290     if (tPtr == &tclIntType) {
2291     i = valuePtr->internalRep.longValue;
2292     objPtr = Tcl_NewLongObj(i);
2293     } else {
2294     d = valuePtr->internalRep.doubleValue;
2295     objPtr = Tcl_NewDoubleObj(d);
2296     }
2297     Tcl_IncrRefCount(objPtr);
2298     Tcl_DecrRefCount(valuePtr);
2299     valuePtr = objPtr;
2300     stackPtr[stackTop] = valuePtr;
2301     } else {
2302     Tcl_InvalidateStringRep(valuePtr);
2303     }
2304     TRACE_WITH_OBJ(("%s => ", O2S(valuePtr)), valuePtr);
2305     }
2306     ADJUST_PC(1);
2307    
2308     case INST_UMINUS:
2309     case INST_LNOT:
2310     {
2311     /*
2312     * The operand must be numeric. If the operand object is
2313     * unshared modify it directly, otherwise create a copy to
2314     * modify: this is "copy on write". free any old string
2315     * representation since it is now invalid.
2316     */
2317    
2318     double d;
2319     Tcl_ObjType *tPtr;
2320    
2321     valuePtr = POP_OBJECT();
2322     tPtr = valuePtr->typePtr;
2323     if ((tPtr != &tclIntType) && ((tPtr != &tclDoubleType)
2324     || (valuePtr->bytes != NULL))) {
2325     if ((tPtr == &tclBooleanType)
2326     && (valuePtr->bytes == NULL)) {
2327     valuePtr->typePtr = &tclIntType;
2328     } else {
2329     char *s = Tcl_GetStringFromObj(valuePtr, &length);
2330     if (TclLooksLikeInt(s, length)) {
2331     result = Tcl_GetLongFromObj((Tcl_Interp *) NULL,
2332     valuePtr, &i);
2333     } else {
2334     result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL,
2335     valuePtr, &d);
2336     }
2337     if (result != TCL_OK) {
2338     TRACE(("\"%.20s\" => ILLEGAL TYPE %s\n",
2339     s, (tPtr? tPtr->name : "null")));
2340     IllegalExprOperandType(interp, pc, valuePtr);
2341     Tcl_DecrRefCount(valuePtr);
2342     goto checkForCatch;
2343     }
2344     }
2345     tPtr = valuePtr->typePtr;
2346     }
2347    
2348     if (Tcl_IsShared(valuePtr)) {
2349     /*
2350     * Create a new object.
2351     */
2352     if (tPtr == &tclIntType) {
2353     i = valuePtr->internalRep.longValue;
2354     objPtr = Tcl_NewLongObj(
2355     (*pc == INST_UMINUS)? -i : !i);
2356     TRACE_WITH_OBJ(("%ld => ", i), objPtr);
2357     } else {
2358     d = valuePtr->internalRep.doubleValue;
2359     if (*pc == INST_UMINUS) {
2360     objPtr = Tcl_NewDoubleObj(-d);
2361     } else {
2362     /*
2363     * Should be able to use "!d", but apparently
2364     * some compilers can't handle it.
2365     */
2366     objPtr = Tcl_NewLongObj((d==0.0)? 1 : 0);
2367     }
2368     TRACE_WITH_OBJ(("%.6g => ", d), objPtr);
2369     }
2370     PUSH_OBJECT(objPtr);
2371     TclDecrRefCount(valuePtr);
2372     } else {
2373     /*
2374     * valuePtr is unshared. Modify it directly.
2375     */
2376     if (tPtr == &tclIntType) {
2377     i = valuePtr->internalRep.longValue;
2378     Tcl_SetLongObj(valuePtr,
2379     (*pc == INST_UMINUS)? -i : !i);
2380     TRACE_WITH_OBJ(("%ld => ", i), valuePtr);
2381     } else {
2382     d = valuePtr->internalRep.doubleValue;
2383     if (*pc == INST_UMINUS) {
2384     Tcl_SetDoubleObj(valuePtr, -d);
2385     } else {
2386     /*
2387     * Should be able to use "!d", but apparently
2388     * some compilers can't handle it.
2389     */
2390     Tcl_SetLongObj(valuePtr, (d==0.0)? 1 : 0);
2391     }
2392     TRACE_WITH_OBJ(("%.6g => ", d), valuePtr);
2393     }
2394     ++stackTop; /* valuePtr now on stk top has right r.c. */
2395     }
2396     }
2397     ADJUST_PC(1);
2398    
2399     case INST_BITNOT:
2400     {
2401     /*
2402     * The operand must be an integer. If the operand object is
2403     * unshared modify it directly, otherwise modify a copy.
2404     * Free any old string representation since it is now
2405     * invalid.
2406     */
2407    
2408     Tcl_ObjType *tPtr;
2409    
2410     valuePtr = POP_OBJECT();
2411     tPtr = valuePtr->typePtr;
2412     if (tPtr != &tclIntType) {
2413     result = Tcl_GetLongFromObj((Tcl_Interp *) NULL,
2414     valuePtr, &i);
2415     if (result != TCL_OK) { /* try to convert to double */
2416     TRACE(("\"%.20s\" => ILLEGAL TYPE %s\n",
2417     O2S(valuePtr), (tPtr? tPtr->name : "null")));
2418     IllegalExprOperandType(interp, pc, valuePtr);
2419     Tcl_DecrRefCount(valuePtr);
2420     goto checkForCatch;
2421     }
2422     }
2423    
2424     i = valuePtr->internalRep.longValue;
2425     if (Tcl_IsShared(valuePtr)) {
2426     PUSH_OBJECT(Tcl_NewLongObj(~i));
2427     TRACE(("0x%lx => (%lu)\n", i, ~i));
2428     TclDecrRefCount(valuePtr);
2429     } else {
2430     /*
2431     * valuePtr is unshared. Modify it directly.
2432     */
2433     Tcl_SetLongObj(valuePtr, ~i);
2434     ++stackTop; /* valuePtr now on stk top has right r.c. */
2435     TRACE(("0x%lx => (%lu)\n", i, ~i));
2436     }
2437     }
2438     ADJUST_PC(1);
2439    
2440     case INST_CALL_BUILTIN_FUNC1:
2441     opnd = TclGetUInt1AtPtr(pc+1);
2442     {
2443     /*
2444     * Call one of the built-in Tcl math functions.
2445     */
2446    
2447     BuiltinFunc *mathFuncPtr;
2448     ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
2449    
2450     if ((opnd < 0) || (opnd > LAST_BUILTIN_FUNC)) {
2451     TRACE(("UNRECOGNIZED BUILTIN FUNC CODE %d\n", opnd));
2452     panic("TclExecuteByteCode: unrecognized builtin function code %d", opnd);
2453     }
2454     mathFuncPtr = &(builtinFuncTable[opnd]);
2455     DECACHE_STACK_INFO();
2456     tsdPtr->mathInProgress++;
2457     result = (*mathFuncPtr->proc)(interp, eePtr,
2458     mathFuncPtr->clientData);
2459     tsdPtr->mathInProgress--;
2460     CACHE_STACK_INFO();
2461     if (result != TCL_OK) {
2462     goto checkForCatch;
2463     }
2464     TRACE_WITH_OBJ(("%d => ", opnd), stackPtr[stackTop]);
2465     }
2466     ADJUST_PC(2);
2467    
2468     case INST_CALL_FUNC1:
2469     opnd = TclGetUInt1AtPtr(pc+1);
2470     {
2471     /*
2472     * Call a non-builtin Tcl math function previously
2473     * registered by a call to Tcl_CreateMathFunc.
2474     */
2475    
2476     int objc = opnd; /* Number of arguments. The function name
2477     * is the 0-th argument. */
2478     Tcl_Obj **objv; /* The array of arguments. The function
2479     * name is objv[0]. */
2480     ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
2481    
2482     objv = &(stackPtr[stackTop - (objc-1)]); /* "objv[0]" */
2483     DECACHE_STACK_INFO();
2484     tsdPtr->mathInProgress++;
2485     result = ExprCallMathFunc(interp, eePtr, objc, objv);
2486     tsdPtr->mathInProgress--;
2487     CACHE_STACK_INFO();
2488     if (result != TCL_OK) {
2489     goto checkForCatch;
2490     }
2491     TRACE_WITH_OBJ(("%d => ", objc), stackPtr[stackTop]);
2492     ADJUST_PC(2);
2493     }
2494    
2495     case INST_TRY_CVT_TO_NUMERIC:
2496     {
2497     /*
2498     * Try to convert the topmost stack object to an int or
2499     * double object. This is done in order to support Tcl's
2500     * policy of interpreting operands if at all possible as
2501     * first integers, else floating-point numbers.
2502     */
2503    
2504     double d;
2505     char *s;
2506     Tcl_ObjType *tPtr;
2507     int converted, shared;
2508    
2509     valuePtr = stackPtr[stackTop];
2510     tPtr = valuePtr->typePtr;
2511     converted = 0;
2512     if ((tPtr != &tclIntType) && ((tPtr != &tclDoubleType)
2513     || (valuePtr->bytes != NULL))) {
2514     if ((tPtr == &tclBooleanType)
2515     && (valuePtr->bytes == NULL)) {
2516     valuePtr->typePtr = &tclIntType;
2517     converted = 1;
2518     } else {
2519     s = Tcl_GetStringFromObj(valuePtr, &length);
2520     if (TclLooksLikeInt(s, length)) {
2521     result = Tcl_GetLongFromObj((Tcl_Interp *) NULL,
2522     valuePtr, &i);
2523     } else {
2524     result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL,
2525     valuePtr, &d);
2526     }
2527     if (result == TCL_OK) {
2528     converted = 1;
2529     }
2530     result = TCL_OK; /* reset the result variable */
2531     }
2532     tPtr = valuePtr->typePtr;
2533     }
2534    
2535     /*
2536     * Ensure that the topmost stack object, if numeric, has a
2537     * string rep the same as the formatted version of its
2538     * internal rep. This is used, e.g., to make sure that "expr
2539     * {0001}" yields "1", not "0001". We implement this by
2540     * _discarding_ the string rep since we know it will be
2541     * regenerated, if needed later, by formatting the internal
2542     * rep's value. Also check if there has been an IEEE
2543     * floating point error.
2544     */
2545    
2546     if ((tPtr == &tclIntType) || (tPtr == &tclDoubleType)) {
2547     shared = 0;
2548     if (Tcl_IsShared(valuePtr)) {
2549     shared = 1;
2550     if (valuePtr->bytes != NULL) {
2551     /*
2552     * We only need to make a copy of the object
2553     * when it already had a string rep
2554     */
2555     if (tPtr == &tclIntType) {
2556     i = valuePtr->internalRep.longValue;
2557     objPtr = Tcl_NewLongObj(i);
2558     } else {
2559     d = valuePtr->internalRep.doubleValue;
2560     objPtr = Tcl_NewDoubleObj(d);
2561     }
2562     Tcl_IncrRefCount(objPtr);
2563     TclDecrRefCount(valuePtr);
2564     valuePtr = objPtr;
2565     stackPtr[stackTop] = valuePtr;
2566     tPtr = valuePtr->typePtr;
2567     }
2568     } else {
2569     Tcl_InvalidateStringRep(valuePtr);
2570     }
2571    
2572     if (tPtr == &tclDoubleType) {
2573     d = valuePtr->internalRep.doubleValue;
2574     if (IS_NAN(d) || IS_INF(d)) {
2575     TRACE(("\"%.20s\" => IEEE FLOATING PT ERROR\n",
2576     O2S(valuePtr)));
2577     TclExprFloatError(interp, d);
2578     result = TCL_ERROR;
2579     goto checkForCatch;
2580     }
2581     }
2582     shared = shared; /* lint, shared not used. */
2583     converted = converted; /* lint, converted not used. */
2584     TRACE(("\"%.20s\" => numeric, %s, %s\n", O2S(valuePtr),
2585     (converted? "converted" : "not converted"),
2586     (shared? "shared" : "not shared")));
2587     } else {
2588     TRACE(("\"%.20s\" => not numeric\n", O2S(valuePtr)));
2589     }
2590     }
2591     ADJUST_PC(1);
2592    
2593     case INST_BREAK:
2594     /*
2595     * First reset the interpreter's result. Then find the closest
2596     * enclosing loop or catch exception range, if any. If a loop is
2597     * found, terminate its execution. If the closest is a catch
2598     * exception range, jump to its catchOffset. If no enclosing
2599     * range is found, stop execution and return TCL_BREAK.
2600     */
2601    
2602     Tcl_ResetResult(interp);
2603     rangePtr = GetExceptRangeForPc(pc, /*catchOnly*/ 0, codePtr);
2604     if (rangePtr == NULL) {
2605     TRACE(("=> no encl. loop or catch, returning TCL_BREAK\n"));
2606     result = TCL_BREAK;
2607     goto abnormalReturn; /* no catch exists to check */
2608     }
2609     switch (rangePtr->type) {
2610     case LOOP_EXCEPTION_RANGE:
2611     result = TCL_OK;
2612     TRACE(("=> range at %d, new pc %d\n",
2613     rangePtr->codeOffset, rangePtr->breakOffset));
2614     break;
2615     case CATCH_EXCEPTION_RANGE:
2616     result = TCL_BREAK;
2617     TRACE(("=> ...\n"));
2618     goto processCatch; /* it will use rangePtr */
2619     default:
2620     panic("TclExecuteByteCode: unrecognized ExceptionRange type %d\n", rangePtr->type);
2621     }
2622     pc = (codePtr->codeStart + rangePtr->breakOffset);
2623     continue; /* restart outer instruction loop at pc */
2624    
2625     case INST_CONTINUE:
2626     /*
2627     * Find the closest enclosing loop or catch exception range,
2628     * if any. If a loop is found, skip to its next iteration.
2629     * If the closest is a catch exception range, jump to its
2630     * catchOffset. If no enclosing range is found, stop
2631     * execution and return TCL_CONTINUE.
2632     */
2633    
2634     Tcl_ResetResult(interp);
2635     rangePtr = GetExceptRangeForPc(pc, /*catchOnly*/ 0, codePtr);
2636     if (rangePtr == NULL) {
2637     TRACE(("=> no encl. loop or catch, returning TCL_CONTINUE\n"));
2638     result = TCL_CONTINUE;
2639     goto abnormalReturn;
2640     }
2641     switch (rangePtr->type) {
2642     case LOOP_EXCEPTION_RANGE:
2643     if (rangePtr->continueOffset == -1) {
2644     TRACE(("=> loop w/o continue, checking for catch\n"));
2645     goto checkForCatch;
2646     } else {
2647     result = TCL_OK;
2648     TRACE(("=> range at %d, new pc %d\n",
2649     rangePtr->codeOffset, rangePtr->continueOffset));
2650     }
2651     break;
2652     case CATCH_EXCEPTION_RANGE:
2653     result = TCL_CONTINUE;
2654     TRACE(("=> ...\n"));
2655     goto processCatch; /* it will use rangePtr */
2656     default:
2657     panic("TclExecuteByteCode: unrecognized ExceptionRange type %d\n", rangePtr->type);
2658     }
2659     pc = (codePtr->codeStart + rangePtr->continueOffset);
2660     continue; /* restart outer instruction loop at pc */
2661    
2662     case INST_FOREACH_START4:
2663     opnd = TclGetUInt4AtPtr(pc+1);
2664     {
2665     /*
2666     * Initialize the temporary local var that holds the count
2667     * of the number of iterations of the loop body to -1.
2668     */
2669    
2670     ForeachInfo *infoPtr = (ForeachInfo *)
2671     codePtr->auxDataArrayPtr[opnd].clientData;
2672     int iterTmpIndex = infoPtr->loopCtTemp;
2673     Var *compiledLocals = iPtr->varFramePtr->compiledLocals;
2674     Var *iterVarPtr = &(compiledLocals[iterTmpIndex]);
2675     Tcl_Obj *oldValuePtr = iterVarPtr->value.objPtr;
2676    
2677     if (oldValuePtr == NULL) {
2678     iterVarPtr->value.objPtr = Tcl_NewLongObj(-1);
2679     Tcl_IncrRefCount(iterVarPtr->value.objPtr);
2680     } else {
2681     Tcl_SetLongObj(oldValuePtr, -1);
2682     }
2683     TclSetVarScalar(iterVarPtr);
2684     TclClearVarUndefined(iterVarPtr);
2685     TRACE(("%u => loop iter count temp %d\n",
2686     opnd, iterTmpIndex));
2687     }
2688     ADJUST_PC(5);
2689    
2690     case INST_FOREACH_STEP4:
2691     opnd = TclGetUInt4AtPtr(pc+1);
2692     {
2693     /*
2694     * "Step" a foreach loop (i.e., begin its next iteration) by
2695     * assigning the next value list element to each loop var.
2696     */
2697    
2698     ForeachInfo *infoPtr = (ForeachInfo *)
2699     codePtr->auxDataArrayPtr[opnd].clientData;
2700     ForeachVarList *varListPtr;
2701     int numLists = infoPtr->numLists;
2702     Var *compiledLocals = iPtr->varFramePtr->compiledLocals;
2703     Tcl_Obj *listPtr;
2704     List *listRepPtr;
2705     Var *iterVarPtr, *listVarPtr;
2706     int iterNum, listTmpIndex, listLen, numVars;
2707     int varIndex, valIndex, continueLoop, j;
2708    
2709     /*
2710     * Increment the temp holding the loop iteration number.
2711     */
2712    
2713     iterVarPtr = &(compiledLocals[infoPtr->loopCtTemp]);
2714     valuePtr = iterVarPtr->value.objPtr;
2715     iterNum = (valuePtr->internalRep.longValue + 1);
2716     Tcl_SetLongObj(valuePtr, iterNum);
2717    
2718     /*
2719     * Check whether all value lists are exhausted and we should
2720     * stop the loop.
2721     */
2722    
2723     continueLoop = 0;
2724     listTmpIndex = infoPtr->firstValueTemp;
2725     for (i = 0; i < numLists; i++) {
2726     varListPtr = infoPtr->varLists[i];
2727     numVars = varListPtr->numVars;
2728    
2729     listVarPtr = &(compiledLocals[listTmpIndex]);
2730     listPtr = listVarPtr->value.objPtr;
2731     result = Tcl_ListObjLength(interp, listPtr, &listLen);
2732     if (result != TCL_OK) {
2733     TRACE_WITH_OBJ(("%u => ERROR converting list %ld, \"%s\": ",
2734     opnd, i, O2S(listPtr)),
2735     Tcl_GetObjResult(interp));
2736     goto checkForCatch;
2737     }
2738     if (listLen > (iterNum * numVars)) {
2739     continueLoop = 1;
2740     }
2741     listTmpIndex++;
2742     }
2743    
2744     /*
2745     * If some var in some var list still has a remaining list
2746     * element iterate one more time. Assign to var the next
2747     * element from its value list. We already checked above
2748     * that each list temp holds a valid list object.
2749     */
2750    
2751     if (continueLoop) {
2752     listTmpIndex = infoPtr->firstValueTemp;
2753     for (i = 0; i < numLists; i++) {
2754     varListPtr = infoPtr->varLists[i];
2755     numVars = varListPtr->numVars;
2756    
2757     listVarPtr = &(compiledLocals[listTmpIndex]);
2758     listPtr = listVarPtr->value.objPtr;
2759     listRepPtr = (List *) listPtr->internalRep.otherValuePtr;
2760     listLen = listRepPtr->elemCount;
2761    
2762     valIndex = (iterNum * numVars);
2763     for (j = 0; j < numVars; j++) {
2764     int setEmptyStr = 0;
2765     if (valIndex >= listLen) {
2766     setEmptyStr = 1;
2767     valuePtr = Tcl_NewObj();
2768     } else {
2769     valuePtr = listRepPtr->elements[valIndex];
2770     }
2771    
2772     varIndex = varListPtr->varIndexes[j];
2773     DECACHE_STACK_INFO();
2774     value2Ptr = TclSetIndexedScalar(interp,
2775     varIndex, valuePtr, /*leaveErrorMsg*/ 1);
2776     CACHE_STACK_INFO();
2777     if (value2Ptr == NULL) {
2778     TRACE_WITH_OBJ(("%u => ERROR init. index temp %d: ",
2779     opnd, varIndex),
2780     Tcl_GetObjResult(interp));
2781     if (setEmptyStr) {
2782     Tcl_DecrRefCount(valuePtr);
2783     }
2784     result = TCL_ERROR;
2785     goto checkForCatch;
2786     }
2787     valIndex++;
2788     }
2789     listTmpIndex++;
2790     }
2791     }
2792    
2793     /*
2794     * Push 1 if at least one value list had a remaining element
2795     * and the loop should continue. Otherwise push 0.
2796     */
2797    
2798     PUSH_OBJECT(Tcl_NewLongObj(continueLoop));
2799     TRACE(("%u => %d lists, iter %d, %s loop\n",
2800     opnd, numLists, iterNum,
2801     (continueLoop? "continue" : "exit")));
2802     }
2803     ADJUST_PC(5);
2804    
2805     case INST_BEGIN_CATCH4:
2806     /*
2807     * Record start of the catch command with exception range index
2808     * equal to the operand. Push the current stack depth onto the
2809     * special catch stack.
2810     */
2811     catchStackPtr[++catchTop] = stackTop;
2812     TRACE(("%u => catchTop=%d, stackTop=%d\n",
2813     TclGetUInt4AtPtr(pc+1), catchTop, stackTop));
2814     ADJUST_PC(5);
2815    
2816     case INST_END_CATCH:
2817     catchTop--;
2818     result = TCL_OK;
2819     TRACE(("=> catchTop=%d\n", catchTop));
2820     ADJUST_PC(1);
2821    
2822     case INST_PUSH_RESULT:
2823     PUSH_OBJECT(Tcl_GetObjResult(interp));
2824     TRACE_WITH_OBJ(("=> "), Tcl_GetObjResult(interp));
2825     ADJUST_PC(1);
2826    
2827     case INST_PUSH_RETURN_CODE:
2828     PUSH_OBJECT(Tcl_NewLongObj(result));
2829     TRACE(("=> %u\n", result));
2830     ADJUST_PC(1);
2831    
2832     default:
2833     panic("TclExecuteByteCode: unrecognized opCode %u", *pc);
2834     } /* end of switch on opCode */
2835    
2836     /*
2837     * Division by zero in an expression. Control only reaches this
2838     * point by "goto divideByZero".
2839     */
2840    
2841     divideByZero:
2842     Tcl_ResetResult(interp);
2843     Tcl_AppendToObj(Tcl_GetObjResult(interp), "divide by zero", -1);
2844     Tcl_SetErrorCode(interp, "ARITH", "DIVZERO", "divide by zero",
2845     (char *) NULL);
2846     result = TCL_ERROR;
2847    
2848     /*
2849     * Execution has generated an "exception" such as TCL_ERROR. If the
2850     * exception is an error, record information about what was being
2851     * executed when the error occurred. Find the closest enclosing
2852     * catch range, if any. If no enclosing catch range is found, stop
2853     * execution and return the "exception" code.
2854     */
2855    
2856     checkForCatch:
2857     if ((result == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) {
2858     bytes = GetSrcInfoForPc(pc, codePtr, &length);
2859     if (bytes != NULL) {
2860     Tcl_LogCommandInfo(interp, codePtr->source, bytes, length);
2861     iPtr->flags |= ERR_ALREADY_LOGGED;
2862     }
2863     }
2864     rangePtr = GetExceptRangeForPc(pc, /*catchOnly*/ 1, codePtr);
2865     if (rangePtr == NULL) {
2866     #ifdef TCL_COMPILE_DEBUG
2867     if (traceInstructions) {
2868     fprintf(stdout, " ... no enclosing catch, returning %s\n",
2869     StringForResultCode(result));
2870     }
2871     #endif
2872     goto abnormalReturn;
2873     }
2874    
2875     /*
2876     * A catch exception range (rangePtr) was found to handle an
2877     * "exception". It was found either by checkForCatch just above or
2878     * by an instruction during break, continue, or error processing.
2879     * Jump to its catchOffset after unwinding the operand stack to
2880     * the depth it had when starting to execute the range's catch
2881     * command.
2882     */
2883    
2884     processCatch:
2885     while (stackTop > catchStackPtr[catchTop]) {
2886     valuePtr = POP_OBJECT();
2887     TclDecrRefCount(valuePtr);
2888     }
2889     #ifdef TCL_COMPILE_DEBUG
2890     if (traceInstructions) {
2891     fprintf(stdout, " ... found catch at %d, catchTop=%d, unwound to %d, new pc %u\n",
2892     rangePtr->codeOffset, catchTop, catchStackPtr[catchTop],
2893     (unsigned int)(rangePtr->catchOffset));
2894     }
2895     #endif
2896     pc = (codePtr->codeStart + rangePtr->catchOffset);
2897     continue; /* restart the execution loop at pc */
2898     } /* end of infinite loop dispatching on instructions */
2899    
2900     /*
2901     * Abnormal return code. Restore the stack to state it had when starting
2902     * to execute the ByteCode.
2903     */
2904    
2905     abnormalReturn:
2906     while (stackTop > initStackTop) {
2907     valuePtr = POP_OBJECT();
2908     Tcl_DecrRefCount(valuePtr);
2909     }
2910    
2911     /*
2912     * Free the catch stack array if malloc'ed storage was used.
2913     */
2914    
2915     done:
2916     if (catchStackPtr != catchStackStorage) {
2917     ckfree((char *) catchStackPtr);
2918     }
2919     eePtr->stackTop = initStackTop;
2920     return result;
2921     #undef STATIC_CATCH_STACK_SIZE
2922     }
2923    
2924     #ifdef TCL_COMPILE_DEBUG
2925     /*
2926     *----------------------------------------------------------------------
2927     *
2928     * PrintByteCodeInfo --
2929     *
2930     * This procedure prints a summary about a bytecode object to stdout.
2931     * It is called by TclExecuteByteCode when starting to execute the
2932     * bytecode object if tclTraceExec has the value 2 or more.
2933     *
2934     * Results:
2935     * None.
2936     *
2937     * Side effects:
2938     * None.
2939     *
2940     *----------------------------------------------------------------------
2941     */
2942    
2943     static void
2944     PrintByteCodeInfo(codePtr)
2945     register ByteCode *codePtr; /* The bytecode whose summary is printed
2946     * to stdout. */
2947     {
2948     Proc *procPtr = codePtr->procPtr;
2949     Interp *iPtr = (Interp *) *codePtr->interpHandle;
2950    
2951     fprintf(stdout, "\nExecuting ByteCode 0x%x, refCt %u, epoch %u, interp 0x%x (epoch %u)\n",
2952     (unsigned int) codePtr, codePtr->refCount,
2953     codePtr->compileEpoch, (unsigned int) iPtr,
2954     iPtr->compileEpoch);
2955    
2956     fprintf(stdout, " Source: ");
2957     TclPrintSource(stdout, codePtr->source, 60);
2958    
2959     fprintf(stdout, "\n Cmds %d, src %d, inst %u, litObjs %u, aux %d, stkDepth %u, code/src %.2f\n",
2960     codePtr->numCommands, codePtr->numSrcBytes,
2961     codePtr->numCodeBytes, codePtr->numLitObjects,
2962     codePtr->numAuxDataItems, codePtr->maxStackDepth,
2963     #ifdef TCL_COMPILE_STATS
2964     (codePtr->numSrcBytes?
2965     ((float)codePtr->structureSize)/((float)codePtr->numSrcBytes) : 0.0));
2966     #else
2967     0.0);
2968     #endif
2969     #ifdef TCL_COMPILE_STATS
2970     fprintf(stdout, " Code %d = header %d+inst %d+litObj %d+exc %d+aux %d+cmdMap %d\n",
2971     codePtr->structureSize,
2972     (sizeof(ByteCode) - (sizeof(size_t) + sizeof(Tcl_Time))),
2973     codePtr->numCodeBytes,
2974     (codePtr->numLitObjects * sizeof(Tcl_Obj *)),
2975     (codePtr->numExceptRanges * sizeof(ExceptionRange)),
2976     (codePtr->numAuxDataItems * sizeof(AuxData)),
2977     codePtr->numCmdLocBytes);
2978     #endif /* TCL_COMPILE_STATS */
2979     if (procPtr != NULL) {
2980     fprintf(stdout,
2981     " Proc 0x%x, refCt %d, args %d, compiled locals %d\n",
2982     (unsigned int) procPtr, procPtr->refCount,
2983     procPtr->numArgs, procPtr->numCompiledLocals);
2984     }
2985     }
2986     #endif /* TCL_COMPILE_DEBUG */
2987    
2988     /*
2989     *----------------------------------------------------------------------
2990     *
2991     * ValidatePcAndStackTop --
2992     *
2993     * This procedure is called by TclExecuteByteCode when debugging to
2994     * verify that the program counter and stack top are valid during
2995     * execution.
2996     *
2997     * Results:
2998     * None.
2999     *
3000     * Side effects:
3001     * Prints a message to stderr and panics if either the pc or stack
3002     * top are invalid.
3003     *
3004     *----------------------------------------------------------------------
3005     */
3006    
3007     #ifdef TCL_COMPILE_DEBUG
3008     static void
3009     ValidatePcAndStackTop(codePtr, pc, stackTop, stackLowerBound,
3010     stackUpperBound)
3011     register ByteCode *codePtr; /* The bytecode whose summary is printed
3012     * to stdout. */
3013     unsigned char *pc; /* Points to first byte of a bytecode
3014     * instruction. The program counter. */
3015     int stackTop; /* Current stack top. Must be between
3016     * stackLowerBound and stackUpperBound
3017     * (inclusive). */
3018     int stackLowerBound; /* Smallest legal value for stackTop. */
3019     int stackUpperBound; /* Greatest legal value for stackTop. */
3020     {
3021     unsigned int relativePc = (unsigned int) (pc - codePtr->codeStart);
3022     unsigned int codeStart = (unsigned int) codePtr->codeStart;
3023     unsigned int codeEnd = (unsigned int)
3024     (codePtr->codeStart + codePtr->numCodeBytes);
3025     unsigned char opCode = *pc;
3026    
3027     if (((unsigned int) pc < codeStart) || ((unsigned int) pc > codeEnd)) {
3028     fprintf(stderr, "\nBad instruction pc 0x%x in TclExecuteByteCode\n",
3029     (unsigned int) pc);
3030     panic("TclExecuteByteCode execution failure: bad pc");
3031     }
3032     if ((unsigned int) opCode > LAST_INST_OPCODE) {
3033     fprintf(stderr, "\nBad opcode %d at pc %u in TclExecuteByteCode\n",
3034     (unsigned int) opCode, relativePc);
3035     panic("TclExecuteByteCode execution failure: bad opcode");
3036     }
3037     if ((stackTop < stackLowerBound) || (stackTop > stackUpperBound)) {
3038     int numChars;
3039     char *cmd = GetSrcInfoForPc(pc, codePtr, &numChars);
3040     char *ellipsis = "";
3041    
3042     fprintf(stderr, "\nBad stack top %d at pc %u in TclExecuteByteCode",
3043     stackTop, relativePc);
3044     if (cmd != NULL) {
3045     if (numChars > 100) {
3046     numChars = 100;
3047     ellipsis = "...";
3048     }
3049     fprintf(stderr, "\n executing %.*s%s\n", numChars, cmd,
3050     ellipsis);
3051     } else {
3052     fprintf(stderr, "\n");
3053     }
3054     panic("TclExecuteByteCode execution failure: bad stack top");
3055     }
3056     }
3057     #endif /* TCL_COMPILE_DEBUG */
3058    
3059     /*
3060     *----------------------------------------------------------------------
3061     *
3062     * IllegalExprOperandType --
3063     *
3064     * Used by TclExecuteByteCode to add an error message to errorInfo
3065     * when an illegal operand type is detected by an expression
3066     * instruction. The argument opndPtr holds the operand object in error.
3067     *
3068     * Results:
3069     * None.
3070     *
3071     * Side effects:
3072     * An error message is appended to errorInfo.
3073     *
3074     *----------------------------------------------------------------------
3075     */
3076    
3077     static void
3078     IllegalExprOperandType(interp, pc, opndPtr)
3079     Tcl_Interp *interp; /* Interpreter to which error information
3080     * pertains. */
3081     unsigned char *pc; /* Points to the instruction being executed
3082     * when the illegal type was found. */
3083     Tcl_Obj *opndPtr; /* Points to the operand holding the value
3084     * with the illegal type. */
3085     {
3086     unsigned char opCode = *pc;
3087    
3088     Tcl_ResetResult(interp);
3089     if ((opndPtr->bytes == NULL) || (opndPtr->length == 0)) {
3090     Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
3091     "can't use empty string as operand of \"",
3092     operatorStrings[opCode - INST_LOR], "\"", (char *) NULL);
3093     } else {
3094     char *msg = "non-numeric string";
3095     if (opndPtr->typePtr != &tclDoubleType) {
3096     /*
3097     * See if the operand can be interpreted as a double in order to
3098     * improve the error message.
3099     */
3100    
3101     char *s = Tcl_GetString(opndPtr);
3102     double d;
3103    
3104     if (Tcl_GetDouble((Tcl_Interp *) NULL, s, &d) == TCL_OK) {
3105     /*
3106     * Make sure that what appears to be a double
3107     * (ie 08) isn't really a bad octal
3108     */
3109     if (TclCheckBadOctal(NULL, Tcl_GetString(opndPtr))) {
3110     msg = "invalid octal number";
3111     } else {
3112     msg = "floating-point value";
3113     }
3114     }
3115     }
3116     Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "can't use ",
3117     msg, " as operand of \"", operatorStrings[opCode - INST_LOR],
3118     "\"", (char *) NULL);
3119     }
3120     }
3121    
3122     /*
3123     *----------------------------------------------------------------------
3124     *
3125     * CallTraceProcedure --
3126     *
3127     * Invokes a trace procedure registered with an interpreter. These
3128     * procedures trace command execution. Currently this trace procedure
3129     * is called with the address of the string-based Tcl_CmdProc for the
3130     * command, not the Tcl_ObjCmdProc.
3131     *
3132     * Results:
3133     * None.
3134     *
3135     * Side effects:
3136     * Those side effects made by the trace procedure.
3137     *
3138     *----------------------------------------------------------------------
3139     */
3140    
3141     static void
3142     CallTraceProcedure(interp, tracePtr, cmdPtr, command, numChars, objc, objv)
3143     Tcl_Interp *interp; /* The current interpreter. */
3144     register Trace *tracePtr; /* Describes the trace procedure to call. */
3145     Command *cmdPtr; /* Points to command's Command struct. */
3146     char *command; /* Points to the first character of the
3147     * command's source before substitutions. */
3148     int numChars; /* The number of characters in the
3149     * command's source. */
3150     register int objc; /* Number of arguments for the command. */
3151     Tcl_Obj *objv[]; /* Pointers to Tcl_Obj of each argument. */
3152     {
3153     Interp *iPtr = (Interp *) interp;
3154     register char **argv;
3155     register int i;
3156     int length;
3157     char *p;
3158    
3159     /*
3160     * Get the string rep from the objv argument objects and place their
3161     * pointers in argv. First make sure argv is large enough to hold the
3162     * objc args plus 1 extra word for the zero end-of-argv word.
3163     */
3164    
3165     argv = (char **) ckalloc((unsigned)(objc + 1) * sizeof(char *));
3166     for (i = 0; i < objc; i++) {
3167     argv[i] = Tcl_GetStringFromObj(objv[i], &length);
3168     }
3169     argv[objc] = 0;
3170    
3171     /*
3172     * Copy the command characters into a new string.
3173     */
3174    
3175     p = (char *) ckalloc((unsigned) (numChars + 1));
3176     memcpy((VOID *) p, (VOID *) command, (size_t) numChars);
3177     p[numChars] = '\0';
3178    
3179     /*
3180     * Call the trace procedure then free allocated storage.
3181     */
3182    
3183     (*tracePtr->proc)(tracePtr->clientData, interp, iPtr->numLevels,
3184     p, cmdPtr->proc, cmdPtr->clientData, objc, argv);
3185    
3186     ckfree((char *) argv);
3187     ckfree((char *) p);
3188     }
3189    
3190     /*
3191     *----------------------------------------------------------------------
3192     *
3193     * GetSrcInfoForPc --
3194     *
3195     * Given a program counter value, finds the closest command in the
3196     * bytecode code unit's CmdLocation array and returns information about
3197     * that command's source: a pointer to its first byte and the number of
3198     * characters.
3199     *
3200     * Results:
3201     * If a command is found that encloses the program counter value, a
3202     * pointer to the command's source is returned and the length of the
3203     * source is stored at *lengthPtr. If multiple commands resulted in
3204     * code at pc, information about the closest enclosing command is
3205     * returned. If no matching command is found, NULL is returned and
3206     * *lengthPtr is unchanged.
3207     *
3208     * Side effects:
3209     * None.
3210     *
3211     *----------------------------------------------------------------------
3212     */
3213    
3214     static char *
3215     GetSrcInfoForPc(pc, codePtr, lengthPtr)
3216     unsigned char *pc; /* The program counter value for which to
3217     * return the closest command's source info.
3218     * This points to a bytecode instruction
3219     * in codePtr's code. */
3220     ByteCode *codePtr; /* The bytecode sequence in which to look
3221     * up the command source for the pc. */
3222     int *lengthPtr; /* If non-NULL, the location where the
3223     * length of the command's source should be
3224     * stored. If NULL, no length is stored. */
3225     {
3226     register int pcOffset = (pc - codePtr->codeStart);
3227     int numCmds = codePtr->numCommands;
3228     unsigned char *codeDeltaNext, *codeLengthNext;
3229     unsigned char *srcDeltaNext, *srcLengthNext;
3230     int codeOffset, codeLen, codeEnd, srcOffset, srcLen, delta, i;
3231     int bestDist = INT_MAX; /* Distance of pc to best cmd's start pc. */
3232     int bestSrcOffset = -1; /* Initialized to avoid compiler warning. */
3233     int bestSrcLength = -1; /* Initialized to avoid compiler warning. */
3234    
3235     if ((pcOffset < 0) || (pcOffset >= codePtr->numCodeBytes)) {
3236     return NULL;
3237     }
3238    
3239     /*
3240     * Decode the code and source offset and length for each command. The
3241     * closest enclosing command is the last one whose code started before
3242     * pcOffset.
3243     */
3244    
3245     codeDeltaNext = codePtr->codeDeltaStart;
3246     codeLengthNext = codePtr->codeLengthStart;
3247     srcDeltaNext = codePtr->srcDeltaStart;
3248     srcLengthNext = codePtr->srcLengthStart;
3249     codeOffset = srcOffset = 0;
3250     for (i = 0; i < numCmds; i++) {
3251     if ((unsigned int) (*codeDeltaNext) == (unsigned int) 0xFF) {
3252     codeDeltaNext++;
3253     delta = TclGetInt4AtPtr(codeDeltaNext);
3254     codeDeltaNext += 4;
3255     } else {
3256     delta = TclGetInt1AtPtr(codeDeltaNext);
3257     codeDeltaNext++;
3258     }
3259     codeOffset += delta;
3260    
3261     if ((unsigned int) (*codeLengthNext) == (unsigned int) 0xFF) {
3262     codeLengthNext++;
3263     codeLen = TclGetInt4AtPtr(codeLengthNext);
3264     codeLengthNext += 4;
3265     } else {
3266     codeLen = TclGetInt1AtPtr(codeLengthNext);
3267     codeLengthNext++;
3268     }
3269     codeEnd = (codeOffset + codeLen - 1);
3270    
3271     if ((unsigned int) (*srcDeltaNext) == (unsigned int) 0xFF) {
3272     srcDeltaNext++;
3273     delta = TclGetInt4AtPtr(srcDeltaNext);
3274     srcDeltaNext += 4;
3275     } else {
3276     delta = TclGetInt1AtPtr(srcDeltaNext);
3277     srcDeltaNext++;
3278     }
3279     srcOffset += delta;
3280    
3281     if ((unsigned int) (*srcLengthNext) == (unsigned int) 0xFF) {
3282     srcLengthNext++;
3283     srcLen = TclGetInt4AtPtr(srcLengthNext);
3284     srcLengthNext += 4;
3285     } else {
3286     srcLen = TclGetInt1AtPtr(srcLengthNext);
3287     srcLengthNext++;
3288     }
3289    
3290     if (codeOffset > pcOffset) { /* best cmd already found */
3291     break;
3292     } else if (pcOffset <= codeEnd) { /* this cmd's code encloses pc */
3293     int dist = (pcOffset - codeOffset);
3294     if (dist <= bestDist) {
3295     bestDist = dist;
3296     bestSrcOffset = srcOffset;
3297     bestSrcLength = srcLen;
3298     }
3299     }
3300     }
3301    
3302     if (bestDist == INT_MAX) {
3303     return NULL;
3304     }
3305    
3306     if (lengthPtr != NULL) {
3307     *lengthPtr = bestSrcLength;
3308     }
3309     return (codePtr->source + bestSrcOffset);
3310     }
3311    
3312     /*
3313     *----------------------------------------------------------------------
3314     *
3315     * GetExceptRangeForPc --
3316     *
3317     * Given a program counter value, return the closest enclosing
3318     * ExceptionRange.
3319     *
3320     * Results:
3321     * In the normal case, catchOnly is 0 (false) and this procedure
3322     * returns a pointer to the most closely enclosing ExceptionRange
3323     * structure regardless of whether it is a loop or catch exception
3324     * range. This is appropriate when processing a TCL_BREAK or
3325     * TCL_CONTINUE, which will be "handled" either by a loop exception
3326     * range or a closer catch range. If catchOnly is nonzero, this
3327     * procedure ignores loop exception ranges and returns a pointer to the
3328     * closest catch range. If no matching ExceptionRange is found that
3329     * encloses pc, a NULL is returned.
3330     *
3331     * Side effects:
3332     * None.
3333     *
3334     *----------------------------------------------------------------------
3335     */
3336    
3337     static ExceptionRange *
3338     GetExceptRangeForPc(pc, catchOnly, codePtr)
3339     unsigned char *pc; /* The program counter value for which to
3340     * search for a closest enclosing exception
3341     * range. This points to a bytecode
3342     * instruction in codePtr's code. */
3343     int catchOnly; /* If 0, consider either loop or catch
3344     * ExceptionRanges in search. If nonzero
3345     * consider only catch ranges (and ignore
3346     * any closer loop ranges). */
3347     ByteCode* codePtr; /* Points to the ByteCode in which to search
3348     * for the enclosing ExceptionRange. */
3349     {
3350     ExceptionRange *rangeArrayPtr;
3351     int numRanges = codePtr->numExceptRanges;
3352     register ExceptionRange *rangePtr;
3353     int pcOffset = (pc - codePtr->codeStart);
3354     register int i, level;
3355    
3356     if (numRanges == 0) {
3357     return NULL;
3358     }
3359     rangeArrayPtr = codePtr->exceptArrayPtr;
3360    
3361     for (level = codePtr->maxExceptDepth; level >= 0; level--) {
3362     for (i = 0; i < numRanges; i++) {
3363     rangePtr = &(rangeArrayPtr[i]);
3364     if (rangePtr->nestingLevel == level) {
3365     int start = rangePtr->codeOffset;
3366     int end = (start + rangePtr->numCodeBytes);
3367     if ((start <= pcOffset) && (pcOffset < end)) {
3368     if ((!catchOnly)
3369     || (rangePtr->type == CATCH_EXCEPTION_RANGE)) {
3370     return rangePtr;
3371     }
3372     }
3373     }
3374     }
3375     }
3376     return NULL;
3377     }
3378    
3379     /*
3380     *----------------------------------------------------------------------
3381     *
3382     * GetOpcodeName --
3383     *
3384     * This procedure is called by the TRACE and TRACE_WITH_OBJ macros
3385     * used in TclExecuteByteCode when debugging. It returns the name of
3386     * the bytecode instruction at a specified instruction pc.
3387     *
3388     * Results:
3389     * A character string for the instruction.
3390     *
3391     * Side effects:
3392     * None.
3393     *
3394     *----------------------------------------------------------------------
3395     */
3396    
3397     #ifdef TCL_COMPILE_DEBUG
3398     static char *
3399     GetOpcodeName(pc)
3400     unsigned char *pc; /* Points to the instruction whose name
3401     * should be returned. */
3402     {
3403     unsigned char opCode = *pc;
3404    
3405     return instructionTable[opCode].name;
3406     }
3407     #endif /* TCL_COMPILE_DEBUG */
3408    
3409     /*
3410     *----------------------------------------------------------------------
3411     *
3412     * VerifyExprObjType --
3413     *
3414     * This procedure is called by the math functions to verify that
3415     * the object is either an int or double, coercing it if necessary.
3416     * If an error occurs during conversion, an error message is left
3417     * in the interpreter's result unless "interp" is NULL.
3418     *
3419     * Results:
3420     * TCL_OK if it was int or double, TCL_ERROR otherwise
3421     *
3422     * Side effects:
3423     * objPtr is ensured to be either tclIntType of tclDoubleType.
3424     *
3425     *----------------------------------------------------------------------
3426     */
3427    
3428     static int
3429     VerifyExprObjType(interp, objPtr)
3430     Tcl_Interp *interp; /* The interpreter in which to execute the
3431     * function. */
3432     Tcl_Obj *objPtr; /* Points to the object to type check. */
3433     {
3434     if ((objPtr->typePtr == &tclIntType) ||
3435     (objPtr->typePtr == &tclDoubleType)) {
3436     return TCL_OK;
3437     } else {
3438     int length, result = TCL_OK;
3439     char *s = Tcl_GetStringFromObj(objPtr, &length);
3440    
3441     if (TclLooksLikeInt(s, length)) {
3442     long i;
3443     result = Tcl_GetLongFromObj((Tcl_Interp *) NULL, objPtr, &i);
3444     } else {
3445     double d;
3446     result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL, objPtr, &d);
3447     }
3448     if ((result != TCL_OK) && (interp != NULL)) {
3449     Tcl_ResetResult(interp);
3450     if (TclCheckBadOctal((Tcl_Interp *) NULL, s)) {
3451     Tcl_AppendToObj(Tcl_GetObjResult(interp),
3452     "argument to math function was an invalid octal number",
3453     -1);
3454     } else {
3455     Tcl_AppendToObj(Tcl_GetObjResult(interp),
3456     "argument to math function didn't have numeric value",
3457     -1);
3458     }
3459     }
3460     return result;
3461     }
3462     }
3463    
3464     /*
3465     *----------------------------------------------------------------------
3466     *
3467     * Math Functions --
3468     *
3469     * This page contains the procedures that implement all of the
3470     * built-in math functions for expressions.
3471     *
3472     * Results:
3473     * Each procedure returns TCL_OK if it succeeds and pushes an
3474     * Tcl object holding the result. If it fails it returns TCL_ERROR
3475     * and leaves an error message in the interpreter's result.
3476     *
3477     * Side effects:
3478     * None.
3479     *
3480     *----------------------------------------------------------------------
3481     */
3482    
3483     static int
3484     ExprUnaryFunc(interp, eePtr, clientData)
3485     Tcl_Interp *interp; /* The interpreter in which to execute the
3486     * function. */
3487     ExecEnv *eePtr; /* Points to the environment for executing
3488     * the function. */
3489     ClientData clientData; /* Contains the address of a procedure that
3490     * takes one double argument and returns a
3491     * double result. */
3492     {
3493     Tcl_Obj **stackPtr; /* Cached evaluation stack base pointer. */
3494     register int stackTop; /* Cached top index of evaluation stack. */
3495     register Tcl_Obj *valuePtr;
3496     double d, dResult;
3497     int result;
3498    
3499     double (*func) _ANSI_ARGS_((double)) =
3500     (double (*)_ANSI_ARGS_((double))) clientData;
3501    
3502     /*
3503     * Set stackPtr and stackTop from eePtr.
3504     */
3505    
3506     result = TCL_OK;
3507     CACHE_STACK_INFO();
3508    
3509     /*
3510     * Pop the function's argument from the evaluation stack. Convert it
3511     * to a double if necessary.
3512     */
3513    
3514     valuePtr = POP_OBJECT();
3515    
3516     if (VerifyExprObjType(interp, valuePtr) != TCL_OK) {
3517     result = TCL_ERROR;
3518     goto done;
3519     }
3520    
3521     if (valuePtr->typePtr == &tclIntType) {
3522     d = (double) valuePtr->internalRep.longValue;
3523     } else {
3524     d = valuePtr->internalRep.doubleValue;
3525     }
3526    
3527     errno = 0;
3528     dResult = (*func)(d);
3529     if ((errno != 0) || IS_NAN(dResult) || IS_INF(dResult)) {
3530     TclExprFloatError(interp, dResult);
3531     result = TCL_ERROR;
3532     goto done;
3533     }
3534    
3535     /*
3536     * Push a Tcl object holding the result.
3537     */
3538    
3539     PUSH_OBJECT(Tcl_NewDoubleObj(dResult));
3540    
3541     /*
3542     * Reflect the change to stackTop back in eePtr.
3543     */
3544    
3545     done:
3546     Tcl_DecrRefCount(valuePtr);
3547     DECACHE_STACK_INFO();
3548     return result;
3549     }
3550    
3551     static int
3552     ExprBinaryFunc(interp, eePtr, clientData)
3553     Tcl_Interp *interp; /* The interpreter in which to execute the
3554     * function. */
3555     ExecEnv *eePtr; /* Points to the environment for executing
3556     * the function. */
3557     ClientData clientData; /* Contains the address of a procedure that
3558     * takes two double arguments and
3559     * returns a double result. */
3560     {
3561     Tcl_Obj **stackPtr; /* Cached evaluation stack base pointer. */
3562     register int stackTop; /* Cached top index of evaluation stack. */
3563     register Tcl_Obj *valuePtr, *value2Ptr;
3564     double d1, d2, dResult;
3565     int result;
3566    
3567     double (*func) _ANSI_ARGS_((double, double))
3568     = (double (*)_ANSI_ARGS_((double, double))) clientData;
3569    
3570     /*
3571     * Set stackPtr and stackTop from eePtr.
3572     */
3573    
3574     result = TCL_OK;
3575     CACHE_STACK_INFO();
3576    
3577     /*
3578     * Pop the function's two arguments from the evaluation stack. Convert
3579     * them to doubles if necessary.
3580     */
3581    
3582     value2Ptr = POP_OBJECT();
3583     valuePtr = POP_OBJECT();
3584    
3585     if ((VerifyExprObjType(interp, valuePtr) != TCL_OK) ||
3586     (VerifyExprObjType(interp, value2Ptr) != TCL_OK)) {
3587     result = TCL_ERROR;
3588     goto done;
3589     }
3590    
3591     if (valuePtr->typePtr == &tclIntType) {
3592     d1 = (double) valuePtr->internalRep.longValue;
3593     } else {
3594     d1 = valuePtr->internalRep.doubleValue;
3595     }
3596    
3597     if (value2Ptr->typePtr == &tclIntType) {
3598     d2 = (double) value2Ptr->internalRep.longValue;
3599     } else {
3600     d2 = value2Ptr->internalRep.doubleValue;
3601     }
3602    
3603     errno = 0;
3604     dResult = (*func)(d1, d2);
3605     if ((errno != 0) || IS_NAN(dResult) || IS_INF(dResult)) {
3606     TclExprFloatError(interp, dResult);
3607     result = TCL_ERROR;
3608     goto done;
3609     }
3610    
3611     /*
3612     * Push a Tcl object holding the result.
3613     */
3614    
3615     PUSH_OBJECT(Tcl_NewDoubleObj(dResult));
3616    
3617     /*
3618     * Reflect the change to stackTop back in eePtr.
3619     */
3620    
3621     done:
3622     Tcl_DecrRefCount(valuePtr);
3623     Tcl_DecrRefCount(value2Ptr);
3624     DECACHE_STACK_INFO();
3625     return result;
3626     }
3627    
3628     static int
3629     ExprAbsFunc(interp, eePtr, clientData)
3630     Tcl_Interp *interp; /* The interpreter in which to execute the
3631     * function. */
3632     ExecEnv *eePtr; /* Points to the environment for executing
3633     * the function. */
3634     ClientData clientData; /* Ignored. */
3635     {
3636     Tcl_Obj **stackPtr; /* Cached evaluation stack base pointer. */
3637     register int stackTop; /* Cached top index of evaluation stack. */
3638     register Tcl_Obj *valuePtr;
3639     long i, iResult;
3640     double d, dResult;
3641     int result;
3642    
3643     /*
3644     * Set stackPtr and stackTop from eePtr.
3645     */
3646    
3647     result = TCL_OK;
3648     CACHE_STACK_INFO();
3649    
3650     /*
3651     * Pop the argument from the evaluation stack.
3652     */
3653    
3654     valuePtr = POP_OBJECT();
3655    
3656     if (VerifyExprObjType(interp, valuePtr) != TCL_OK) {
3657     result = TCL_ERROR;
3658     goto done;
3659     }
3660    
3661     /*
3662     * Push a Tcl object with the result.
3663     */
3664     if (valuePtr->typePtr == &tclIntType) {
3665     i = valuePtr->internalRep.longValue;
3666     if (i < 0) {
3667     iResult = -i;
3668     if (iResult < 0) {
3669     Tcl_ResetResult(interp);
3670     Tcl_AppendToObj(Tcl_GetObjResult(interp),
3671     "integer value too large to represent", -1);
3672     Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW",
3673     "integer value too large to represent", (char *) NULL);
3674     result = TCL_ERROR;
3675     goto done;
3676     }
3677     } else {
3678     iResult = i;
3679     }
3680     PUSH_OBJECT(Tcl_NewLongObj(iResult));
3681     } else {
3682     d = valuePtr->internalRep.doubleValue;
3683     if (d < 0.0) {
3684     dResult = -d;
3685     } else {
3686     dResult = d;
3687     }
3688     if (IS_NAN(dResult) || IS_INF(dResult)) {
3689     TclExprFloatError(interp, dResult);
3690     result = TCL_ERROR;
3691     goto done;
3692     }
3693     PUSH_OBJECT(Tcl_NewDoubleObj(dResult));
3694     }
3695    
3696     /*
3697     * Reflect the change to stackTop back in eePtr.
3698     */
3699    
3700     done:
3701     Tcl_DecrRefCount(valuePtr);
3702     DECACHE_STACK_INFO();
3703     return result;
3704     }
3705    
3706     static int
3707     ExprDoubleFunc(interp, eePtr, clientData)
3708     Tcl_Interp *interp; /* The interpreter in which to execute the
3709     * function. */
3710     ExecEnv *eePtr; /* Points to the environment for executing
3711     * the function. */
3712     ClientData clientData; /* Ignored. */
3713     {
3714     Tcl_Obj **stackPtr; /* Cached evaluation stack base pointer. */
3715     register int stackTop; /* Cached top index of evaluation stack. */
3716     register Tcl_Obj *valuePtr;
3717     double dResult;
3718     int result;
3719    
3720     /*
3721     * Set stackPtr and stackTop from eePtr.
3722     */
3723    
3724     result = TCL_OK;
3725     CACHE_STACK_INFO();
3726    
3727     /*
3728     * Pop the argument from the evaluation stack.
3729     */
3730    
3731     valuePtr = POP_OBJECT();
3732    
3733     if (VerifyExprObjType(interp, valuePtr) != TCL_OK) {
3734     result = TCL_ERROR;
3735     goto done;
3736     }
3737    
3738     if (valuePtr->typePtr == &tclIntType) {
3739     dResult = (double) valuePtr->internalRep.longValue;
3740     } else {
3741     dResult = valuePtr->internalRep.doubleValue;
3742     }
3743    
3744     /*
3745     * Push a Tcl object with the result.
3746     */
3747    
3748     PUSH_OBJECT(Tcl_NewDoubleObj(dResult));
3749    
3750     /*
3751     * Reflect the change to stackTop back in eePtr.
3752     */
3753    
3754     done:
3755     Tcl_DecrRefCount(valuePtr);
3756     DECACHE_STACK_INFO();
3757     return result;
3758     }
3759    
3760     static int
3761     ExprIntFunc(interp, eePtr, clientData)
3762     Tcl_Interp *interp; /* The interpreter in which to execute the
3763     * function. */
3764     ExecEnv *eePtr; /* Points to the environment for executing
3765     * the function. */
3766     ClientData clientData; /* Ignored. */
3767     {
3768     Tcl_Obj **stackPtr; /* Cached evaluation stack base pointer. */
3769     register int stackTop; /* Cached top index of evaluation stack. */
3770     register Tcl_Obj *valuePtr;
3771     long iResult;
3772     double d;
3773     int result;
3774    
3775     /*
3776     * Set stackPtr and stackTop from eePtr.
3777     */
3778    
3779     result = TCL_OK;
3780     CACHE_STACK_INFO();
3781    
3782     /*
3783     * Pop the argument from the evaluation stack.
3784     */
3785    
3786     valuePtr = POP_OBJECT();
3787    
3788     if (VerifyExprObjType(interp, valuePtr) != TCL_OK) {
3789     result = TCL_ERROR;
3790     goto done;
3791     }
3792    
3793     if (valuePtr->typePtr == &tclIntType) {
3794     iResult = valuePtr->internalRep.longValue;
3795     } else {
3796     d = valuePtr->internalRep.doubleValue;
3797     if (d < 0.0) {
3798     if (d < (double) (long) LONG_MIN) {
3799     tooLarge:
3800     Tcl_ResetResult(interp);
3801     Tcl_AppendToObj(Tcl_GetObjResult(interp),
3802     "integer value too large to represent", -1);
3803     Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW",
3804     "integer value too large to represent", (char *) NULL);
3805     result = TCL_ERROR;
3806     goto done;
3807     }
3808     } else {
3809     if (d > (double) LONG_MAX) {