diff options
Diffstat (limited to 'generic/tclExecute.c')
| -rw-r--r-- | generic/tclExecute.c | 4929 |
1 files changed, 4929 insertions, 0 deletions
diff --git a/generic/tclExecute.c b/generic/tclExecute.c new file mode 100644 index 0000000..c6cea08 --- /dev/null +++ b/generic/tclExecute.c @@ -0,0 +1,4929 @@ +/* + * tclExecute.c -- + * + * This file contains procedures that execute byte-compiled Tcl + * commands. + * + * Copyright (c) 1996-1997 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tclExecute.c 1.102 97/11/06 11:36:35 + */ + +#include "tclInt.h" +#include "tclCompile.h" + +#ifdef NO_FLOAT_H +# include "../compat/float.h" +#else +# include <float.h> +#endif +#ifndef TCL_NO_MATH +#include "tclMath.h" +#endif + +/* + * The stuff below is a bit of a hack so that this file can be used + * in environments that include no UNIX, i.e. no errno. Just define + * errno here. + */ + +#ifndef TCL_GENERIC_ONLY +#include "tclPort.h" +#else +#define NO_ERRNO_H +#endif + +#ifdef NO_ERRNO_H +int errno; +#define EDOM 33 +#define ERANGE 34 +#endif + +/* + * Boolean flag indicating whether the Tcl bytecode interpreter has been + * initialized. + */ + +static int execInitialized = 0; + +/* + * Variable that controls whether execution tracing is enabled and, if so, + * what level of tracing is desired: + * 0: no execution tracing + * 1: trace invocations of Tcl procs only + * 2: trace invocations of all (not compiled away) commands + * 3: display each instruction executed + * This variable is linked to the Tcl variable "tcl_traceExec". + */ + +int tclTraceExec = 0; + +/* + * The following global variable is use to signal matherr that Tcl + * is responsible for the arithmetic, so errors can be handled in a + * fashion appropriate for Tcl. Zero means no Tcl math is in + * progress; non-zero means Tcl is doing math. + */ + +int tcl_MathInProgress = 0; + +/* + * The variable below serves no useful purpose except to generate + * a reference to matherr, so that the Tcl version of matherr is + * linked in rather than the system version. Without this reference + * the need for matherr won't be discovered during linking until after + * libtcl.a has been processed, so Tcl's version won't be used. + */ + +#ifdef NEED_MATHERR +extern int matherr(); +int (*tclMatherrPtr)() = matherr; +#endif + +/* + * Array of instruction names. + */ + +static char *opName[256]; + +/* + * Mapping from expression instruction opcodes to strings; used for error + * messages. Note that these entries must match the order and number of the + * expression opcodes (e.g., INST_LOR) in tclCompile.h. + */ + +static char *operatorStrings[] = { + "||", "&&", "|", "^", "&", "==", "!=", "<", ">", "<=", ">=", "<<", ">>", + "+", "-", "*", "/", "%", "+", "-", "~", "!", + "BUILTIN FUNCTION", "FUNCTION" +}; + +/* + * Mapping from Tcl result codes to strings; used for error and debugging + * messages. + */ + +#ifdef TCL_COMPILE_DEBUG +static char *resultStrings[] = { + "TCL_OK", "TCL_ERROR", "TCL_RETURN", "TCL_BREAK", "TCL_CONTINUE" +}; +#endif /* TCL_COMPILE_DEBUG */ + +/* + * The following are statistics-related variables that record information + * about the bytecode compiler and interpreter's operation. This includes + * an array that records for each instruction how often it is executed. + */ + +#ifdef TCL_COMPILE_STATS +static long numExecutions = 0; +static int instructionCount[256]; +#endif /* TCL_COMPILE_STATS */ + +/* + * Macros for testing floating-point values for certain special cases. Test + * for not-a-number by comparing a value against itself; test for infinity + * by comparing against the largest floating-point value. + */ + +#define IS_NAN(v) ((v) != (v)) +#ifdef DBL_MAX +# define IS_INF(v) (((v) > DBL_MAX) || ((v) < -DBL_MAX)) +#else +# define IS_INF(v) 0 +#endif + +/* + * Macro to adjust the program counter and restart the instruction execution + * loop after each instruction is executed. + */ + +#define ADJUST_PC(instBytes) \ + pc += instBytes; continue + +/* + * Macros used to cache often-referenced Tcl evaluation stack information + * in local variables. Note that a DECACHE_STACK_INFO()-CACHE_STACK_INFO() + * pair must surround any call inside TclExecuteByteCode (and a few other + * procedures that use this scheme) that could result in a recursive call + * to TclExecuteByteCode. + */ + +#define CACHE_STACK_INFO() \ + stackPtr = eePtr->stackPtr; \ + stackTop = eePtr->stackTop + +#define DECACHE_STACK_INFO() \ + eePtr->stackTop = stackTop + +/* + * Macros used to access items on the Tcl evaluation stack. PUSH_OBJECT + * increments the object's ref count since it makes the stack have another + * reference pointing to the object. However, POP_OBJECT does not decrement + * the ref count. This is because the stack may hold the only reference to + * the object, so the object would be destroyed if its ref count were + * decremented before the caller had a chance to, e.g., store it in a + * variable. It is the caller's responsibility to decrement the ref count + * when it is finished with an object. + */ + +#define STK_ITEM(offset) (stackPtr[stackTop + (offset)]) +#define STK_OBJECT(offset) (STK_ITEM(offset).o) +#define STK_INT(offset) (STK_ITEM(offset).i) +#define STK_POINTER(offset) (STK_ITEM(offset).p) + +/* + * WARNING! It is essential that objPtr only appear once in the PUSH_OBJECT + * macro. The actual parameter might be an expression with side effects, + * and this ensures that it will be executed only once. + */ + +#define PUSH_OBJECT(objPtr) \ + Tcl_IncrRefCount(stackPtr[++stackTop].o = (objPtr)) + +#define POP_OBJECT() \ + (stackPtr[stackTop--].o) + +/* + * Macros used to trace instruction execution. The macros TRACE, + * TRACE_WITH_OBJ, and O2S are only used inside TclExecuteByteCode. + * O2S is only used in TRACE* calls to get a string from an object. + * + * NOTE THAT CLIENTS OF O2S ARE LIKELY TO FAIL IF THE OBJECT'S + * STRING REP CONTAINS NULLS. + */ + +#ifdef TCL_COMPILE_DEBUG + +#define O2S(objPtr) \ + Tcl_GetStringFromObj((objPtr), &length) + +#ifdef TCL_COMPILE_STATS +#define TRACE(a) \ + if (traceInstructions) { \ + fprintf(stdout, "%d: %d,%ld (%u) ", iPtr->numLevels, \ + stackTop, (tclObjsAlloced - tclObjsFreed), \ + (unsigned int)(pc - codePtr->codeStart)); \ + printf a; \ + fflush(stdout); \ + } +#define TRACE_WITH_OBJ(a, objPtr) \ + if (traceInstructions) { \ + fprintf(stdout, "%d: %d,%ld (%u) ", iPtr->numLevels, \ + stackTop, (tclObjsAlloced - tclObjsFreed), \ + (unsigned int)(pc - codePtr->codeStart)); \ + printf a; \ + bytes = Tcl_GetStringFromObj((objPtr), &length); \ + TclPrintSource(stdout, bytes, TclMin(length, 30)); \ + fprintf(stdout, "\n"); \ + fflush(stdout); \ + } +#else /* not TCL_COMPILE_STATS */ +#define TRACE(a) \ + if (traceInstructions) { \ + fprintf(stdout, "%d: %d (%u) ", iPtr->numLevels, stackTop, \ + (unsigned int)(pc - codePtr->codeStart)); \ + printf a; \ + fflush(stdout); \ + } +#define TRACE_WITH_OBJ(a, objPtr) \ + if (traceInstructions) { \ + fprintf(stdout, "%d: %d (%u) ", iPtr->numLevels, stackTop, \ + (unsigned int)(pc - codePtr->codeStart)); \ + printf a; \ + bytes = Tcl_GetStringFromObj((objPtr), &length); \ + TclPrintSource(stdout, bytes, TclMin(length, 30)); \ + fprintf(stdout, "\n"); \ + fflush(stdout); \ + } +#endif /* TCL_COMPILE_STATS */ + +#else /* not TCL_COMPILE_DEBUG */ + +#define TRACE(a) +#define TRACE_WITH_OBJ(a, objPtr) +#define O2S(objPtr) + +#endif /* TCL_COMPILE_DEBUG */ + +/* + * Declarations for local procedures to this file: + */ + +static void CallTraceProcedure _ANSI_ARGS_((Tcl_Interp *interp, + Trace *tracePtr, Command *cmdPtr, + char *command, int numChars, + int objc, Tcl_Obj *objv[])); +static void DupCmdNameInternalRep _ANSI_ARGS_((Tcl_Obj *objPtr, + Tcl_Obj *copyPtr)); +static int ExprAbsFunc _ANSI_ARGS_((Tcl_Interp *interp, + ExecEnv *eePtr, ClientData clientData)); +static int ExprBinaryFunc _ANSI_ARGS_((Tcl_Interp *interp, + ExecEnv *eePtr, ClientData clientData)); +static int ExprCallMathFunc _ANSI_ARGS_((Tcl_Interp *interp, + ExecEnv *eePtr, int objc, Tcl_Obj **objv)); +static int ExprDoubleFunc _ANSI_ARGS_((Tcl_Interp *interp, + ExecEnv *eePtr, ClientData clientData)); +static int ExprIntFunc _ANSI_ARGS_((Tcl_Interp *interp, + ExecEnv *eePtr, ClientData clientData)); +static int ExprRandFunc _ANSI_ARGS_((Tcl_Interp *interp, + ExecEnv *eePtr, ClientData clientData)); +static int ExprRoundFunc _ANSI_ARGS_((Tcl_Interp *interp, + ExecEnv *eePtr, ClientData clientData)); +static int ExprSrandFunc _ANSI_ARGS_((Tcl_Interp *interp, + ExecEnv *eePtr, ClientData clientData)); +static int ExprUnaryFunc _ANSI_ARGS_((Tcl_Interp *interp, + ExecEnv *eePtr, ClientData clientData)); +#ifdef TCL_COMPILE_STATS +static int EvalStatsCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +#endif /* TCL_COMPILE_STATS */ +static void FreeCmdNameInternalRep _ANSI_ARGS_(( + Tcl_Obj *objPtr)); +static char * GetSrcInfoForPc _ANSI_ARGS_((unsigned char *pc, + ByteCode* codePtr, int *lengthPtr)); +static void GrowEvaluationStack _ANSI_ARGS_((ExecEnv *eePtr)); +static void IllegalExprOperandType _ANSI_ARGS_(( + Tcl_Interp *interp, unsigned int opCode, + Tcl_Obj *opndPtr)); +static void InitByteCodeExecution _ANSI_ARGS_(( + Tcl_Interp *interp)); +static void PrintByteCodeInfo _ANSI_ARGS_((ByteCode *codePtr)); +static void RecordTracebackInfo _ANSI_ARGS_((Tcl_Interp *interp, + unsigned char *pc, ByteCode *codePtr)); +static int SetCmdNameFromAny _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Obj *objPtr)); +#ifdef TCL_COMPILE_DEBUG +static char * StringForResultCode _ANSI_ARGS_((int result)); +#endif /* TCL_COMPILE_DEBUG */ +static void UpdateStringOfCmdName _ANSI_ARGS_((Tcl_Obj *objPtr)); +#ifdef TCL_COMPILE_DEBUG +static void ValidatePcAndStackTop _ANSI_ARGS_(( + ByteCode *codePtr, unsigned char *pc, + int stackTop, int stackLowerBound, + int stackUpperBound)); +#endif /* TCL_COMPILE_DEBUG */ + +/* + * Table describing the built-in math functions. Entries in this table are + * indexed by the values of the INST_CALL_BUILTIN_FUNC instruction's + * operand byte. + */ + +BuiltinFunc builtinFuncTable[] = { +#ifndef TCL_NO_MATH + {"acos", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) acos}, + {"asin", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) asin}, + {"atan", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) atan}, + {"atan2", 2, {TCL_DOUBLE, TCL_DOUBLE}, ExprBinaryFunc, (ClientData) atan2}, + {"ceil", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) ceil}, + {"cos", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) cos}, + {"cosh", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) cosh}, + {"exp", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) exp}, + {"floor", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) floor}, + {"fmod", 2, {TCL_DOUBLE, TCL_DOUBLE}, ExprBinaryFunc, (ClientData) fmod}, + {"hypot", 2, {TCL_DOUBLE, TCL_DOUBLE}, ExprBinaryFunc, (ClientData) hypot}, + {"log", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) log}, + {"log10", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) log10}, + {"pow", 2, {TCL_DOUBLE, TCL_DOUBLE}, ExprBinaryFunc, (ClientData) pow}, + {"sin", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) sin}, + {"sinh", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) sinh}, + {"sqrt", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) sqrt}, + {"tan", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) tan}, + {"tanh", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) tanh}, +#endif + {"abs", 1, {TCL_EITHER}, ExprAbsFunc, 0}, + {"double", 1, {TCL_EITHER}, ExprDoubleFunc, 0}, + {"int", 1, {TCL_EITHER}, ExprIntFunc, 0}, + {"rand", 0, {TCL_EITHER}, ExprRandFunc, 0}, /* NOTE: rand takes no args. */ + {"round", 1, {TCL_EITHER}, ExprRoundFunc, 0}, + {"srand", 1, {TCL_INT}, ExprSrandFunc, 0}, + {0}, +}; + +/* + * The structure below defines the command name Tcl object type by means of + * procedures that can be invoked by generic object code. Objects of this + * type cache the Command pointer that results from looking up command names + * in the command hashtable. Such objects appear as the zeroth ("command + * name") argument in a Tcl command. + */ + +Tcl_ObjType tclCmdNameType = { + "cmdName", /* name */ + FreeCmdNameInternalRep, /* freeIntRepProc */ + DupCmdNameInternalRep, /* dupIntRepProc */ + UpdateStringOfCmdName, /* updateStringProc */ + SetCmdNameFromAny /* setFromAnyProc */ +}; + +/* + *---------------------------------------------------------------------- + * + * InitByteCodeExecution -- + * + * This procedure is called once to initialize the Tcl bytecode + * interpreter. + * + * Results: + * None. + * + * Side effects: + * This procedure initializes the array of instruction names. If + * compiling with the TCL_COMPILE_STATS flag, it initializes the + * array that counts the executions of each instruction and it + * creates the "evalstats" command. It also registers the command name + * Tcl_ObjType. It also establishes the link between the Tcl + * "tcl_traceExec" and C "tclTraceExec" variables. + * + *---------------------------------------------------------------------- + */ + +static void +InitByteCodeExecution(interp) + Tcl_Interp *interp; /* Interpreter for which the Tcl variable + * "tcl_traceExec" is linked to control + * instruction tracing. */ +{ + int i; + + Tcl_RegisterObjType(&tclCmdNameType); + + (VOID *) memset(opName, 0, sizeof(opName)); + for (i = 0; instructionTable[i].name != NULL; i++) { + opName[i] = instructionTable[i].name; + } + +#ifdef TCL_COMPILE_STATS + (VOID *) memset(instructionCount, 0, sizeof(instructionCount)); + (VOID *) memset(tclByteCodeCount, 0, sizeof(tclByteCodeCount)); + (VOID *) memset(tclSourceCount, 0, sizeof(tclSourceCount)); + + Tcl_CreateCommand(interp, "evalstats", EvalStatsCmd, + (ClientData) NULL, (Tcl_CmdDeleteProc *) NULL); +#endif /* TCL_COMPILE_STATS */ + + if (Tcl_LinkVar(interp, "tcl_traceExec", (char *) &tclTraceExec, + TCL_LINK_INT) != TCL_OK) { + panic("InitByteCodeExecution: can't create link for tcl_traceExec variable"); + } +} + +/* + *---------------------------------------------------------------------- + * + * TclCreateExecEnv -- + * + * This procedure creates a new execution environment for Tcl bytecode + * execution. An ExecEnv points to a Tcl evaluation stack. An ExecEnv + * is typically created once for each Tcl interpreter (Interp + * structure) and recursively passed to TclExecuteByteCode to execute + * ByteCode sequences for nested commands. + * + * Results: + * A newly allocated ExecEnv is returned. This points to an empty + * evaluation stack of the standard initial size. + * + * Side effects: + * The bytecode interpreter is also initialized here, as this + * procedure will be called before any call to TclExecuteByteCode. + * + *---------------------------------------------------------------------- + */ + +#define TCL_STACK_INITIAL_SIZE 2000 + +ExecEnv * +TclCreateExecEnv(interp) + Tcl_Interp *interp; /* Interpreter for which the execution + * environment is being created. */ +{ + ExecEnv *eePtr = (ExecEnv *) ckalloc(sizeof(ExecEnv)); + + eePtr->stackPtr = (StackItem *) + ckalloc((unsigned) (TCL_STACK_INITIAL_SIZE * sizeof(StackItem))); + eePtr->stackTop = -1; + eePtr->stackEnd = (TCL_STACK_INITIAL_SIZE - 1); + + if (!execInitialized) { + InitByteCodeExecution(interp); + execInitialized = 1; + } + + return eePtr; +} +#undef TCL_STACK_INITIAL_SIZE + +/* + *---------------------------------------------------------------------- + * + * TclDeleteExecEnv -- + * + * Frees the storage for an ExecEnv. + * + * Results: + * None. + * + * Side effects: + * Storage for an ExecEnv and its contained storage (e.g. the + * evaluation stack) is freed. + * + *---------------------------------------------------------------------- + */ + +void +TclDeleteExecEnv(eePtr) + ExecEnv *eePtr; /* Execution environment to free. */ +{ + ckfree((char *) eePtr->stackPtr); + ckfree((char *) eePtr); +} + +/* + *---------------------------------------------------------------------- + * + * TclFinalizeExecEnv -- + * + * Finalizes the execution environment setup so that it can be + * later reinitialized. + * + * Results: + * None. + * + * Side effects: + * After this call, the next time TclCreateExecEnv will be called + * it will call InitByteCodeExecution. + * + *---------------------------------------------------------------------- + */ + +void +TclFinalizeExecEnv() +{ + execInitialized = 0; +} + +/* + *---------------------------------------------------------------------- + * + * GrowEvaluationStack -- + * + * This procedure grows a Tcl evaluation stack stored in an ExecEnv. + * + * Results: + * None. + * + * Side effects: + * The size of the evaluation stack is doubled. + * + *---------------------------------------------------------------------- + */ + +static void +GrowEvaluationStack(eePtr) + register ExecEnv *eePtr; /* Points to the ExecEnv with an evaluation + * stack to enlarge. */ +{ + /* + * The current Tcl stack elements are stored from eePtr->stackPtr[0] + * to eePtr->stackPtr[eePtr->stackEnd] (inclusive). + */ + + int currElems = (eePtr->stackEnd + 1); + int newElems = 2*currElems; + int currBytes = currElems * sizeof(StackItem); + int newBytes = 2*currBytes; + StackItem *newStackPtr = (StackItem *) ckalloc((unsigned) newBytes); + + /* + * Copy the existing stack items to the new stack space, free the old + * storage if appropriate, and mark new space as malloc'ed. + */ + + memcpy((VOID *) newStackPtr, (VOID *) eePtr->stackPtr, + (size_t) currBytes); + ckfree((char *) eePtr->stackPtr); + eePtr->stackPtr = newStackPtr; + eePtr->stackEnd = (newElems - 1); /* i.e. index of last usable item */ +} + +/* + *---------------------------------------------------------------------- + * + * TclExecuteByteCode -- + * + * This procedure executes the instructions of a ByteCode structure. + * It returns when a "done" instruction is executed or an error occurs. + * + * Results: + * The return value is one of the return codes defined in tcl.h + * (such as TCL_OK), and interp->objResultPtr refers to a Tcl object + * that either contains the result of executing the code or an + * error message. + * + * Side effects: + * Almost certainly, depending on the ByteCode's instructions. + * + *---------------------------------------------------------------------- + */ + +int +TclExecuteByteCode(interp, codePtr) + Tcl_Interp *interp; /* Token for command interpreter. */ + ByteCode *codePtr; /* The bytecode sequence to interpret. */ +{ + Interp *iPtr = (Interp *) interp; + ExecEnv *eePtr = iPtr->execEnvPtr; + /* Points to the execution environment. */ + register StackItem *stackPtr = eePtr->stackPtr; + /* Cached evaluation stack base pointer. */ + register int stackTop = eePtr->stackTop; + /* Cached top index of evaluation stack. */ + Tcl_Obj **objArrayPtr = codePtr->objArrayPtr; + /* Points to the ByteCode's object array. */ + unsigned char *pc = codePtr->codeStart; + /* The current program counter. */ + unsigned char opCode; /* The current instruction code. */ + int opnd; /* Current instruction's operand byte. */ + int pcAdjustment; /* Hold pc adjustment after instruction. */ + int initStackTop = stackTop;/* Stack top at start of execution. */ + ExceptionRange *rangePtr; /* Points to closest loop or catch exception + * range enclosing the pc. Used by various + * instructions and processCatch to + * process break, continue, and errors. */ + int result = TCL_OK; /* Return code returned after execution. */ + int traceInstructions = (tclTraceExec == 3); + Tcl_Obj *valuePtr, *value2Ptr, *namePtr, *objPtr; + char *bytes; + int length; + long i; + Tcl_DString command; /* Used for debugging. If tclTraceExec >= 2 + * holds a string representing the last + * command invoked. */ + + /* + * This procedure uses a stack to hold information about catch commands. + * This information is the current operand stack top when starting to + * execute the code for each catch command. It starts out with stack- + * allocated space but uses dynamically-allocated storage if needed. + */ + +#define STATIC_CATCH_STACK_SIZE 5 + int (catchStackStorage[STATIC_CATCH_STACK_SIZE]); + int *catchStackPtr = catchStackStorage; + int catchTop = -1; + + /* + * THIS PROC FAILS IF AN OBJECT'S STRING REP HAS A NULL BYTE. + */ + + if (tclTraceExec >= 2) { + PrintByteCodeInfo(codePtr); +#ifdef TCL_COMPILE_STATS + fprintf(stdout, " Starting stack top=%d, system objects=%ld\n", + eePtr->stackTop, (tclObjsAlloced - tclObjsFreed)); +#else + fprintf(stdout, " Starting stack top=%d\n", eePtr->stackTop); +#endif /* TCL_COMPILE_STATS */ + fflush(stdout); + } + +#ifdef TCL_COMPILE_STATS + numExecutions++; +#endif /* TCL_COMPILE_STATS */ + + /* + * Make sure the catch stack is large enough to hold the maximum number + * of catch commands that could ever be executing at the same time. This + * will be no more than the exception range array's depth. + */ + + if (codePtr->maxExcRangeDepth > STATIC_CATCH_STACK_SIZE) { + catchStackPtr = (int *) + ckalloc(codePtr->maxExcRangeDepth * sizeof(int)); + } + + /* + * Make sure the stack has enough room to execute this ByteCode. + */ + + while ((stackTop + codePtr->maxStackDepth) > eePtr->stackEnd) { + GrowEvaluationStack(eePtr); + stackPtr = eePtr->stackPtr; + } + + /* + * Initialize the buffer that holds a string containing the name and + * arguments for the last invoked command. + */ + + Tcl_DStringInit(&command); + + /* + * Loop executing instructions until a "done" instruction, a TCL_RETURN, + * or some error. + */ + + for (;;) { +#ifdef TCL_COMPILE_DEBUG + ValidatePcAndStackTop(codePtr, pc, stackTop, initStackTop, + eePtr->stackEnd); +#else /* not TCL_COMPILE_DEBUG */ + if (traceInstructions) { +#ifdef TCL_COMPILE_STATS + fprintf(stdout, "%d: %d,%ld ", iPtr->numLevels, stackTop, + (tclObjsAlloced - tclObjsFreed)); +#else /* TCL_COMPILE_STATS */ + fprintf(stdout, "%d: %d ", iPtr->numLevels, stackTop); +#endif /* TCL_COMPILE_STATS */ + TclPrintInstruction(codePtr, pc); + fflush(stdout); + } +#endif /* TCL_COMPILE_DEBUG */ + + opCode = *pc; +#ifdef TCL_COMPILE_STATS + instructionCount[opCode]++; +#endif /* TCL_COMPILE_STATS */ + + switch (opCode) { + case INST_DONE: + /* + * Pop the topmost object from the stack, set the interpreter's + * object result to point to it, and return. + */ + valuePtr = POP_OBJECT(); + Tcl_SetObjResult(interp, valuePtr); + TclDecrRefCount(valuePtr); + if (stackTop != initStackTop) { + fprintf(stderr, "\nTclExecuteByteCode: done instruction at pc %u: stack top %d != entry stack top %d\n", + (unsigned int)(pc - codePtr->codeStart), + (unsigned int) stackTop, + (unsigned int) initStackTop); + fprintf(stderr, " Source: "); + TclPrintSource(stderr, codePtr->source, 150); + panic("TclExecuteByteCode execution failure: end stack top != start stack top"); + } + TRACE_WITH_OBJ(("done => return code=%d, result is ", result), + iPtr->objResultPtr); + goto done; + + case INST_PUSH1: + valuePtr = objArrayPtr[TclGetUInt1AtPtr(pc+1)]; + PUSH_OBJECT(valuePtr); + TRACE_WITH_OBJ(("push1 %u => ", TclGetUInt1AtPtr(pc+1)), + valuePtr); + ADJUST_PC(2); + + case INST_PUSH4: + valuePtr = objArrayPtr[TclGetUInt4AtPtr(pc+1)]; + PUSH_OBJECT(valuePtr); + TRACE_WITH_OBJ(("push4 %u => ", TclGetUInt4AtPtr(pc+1)), + valuePtr); + ADJUST_PC(5); + + case INST_POP: + valuePtr = POP_OBJECT(); + TRACE_WITH_OBJ(("pop => discarding "), valuePtr); + TclDecrRefCount(valuePtr); /* finished with pop'ed object. */ + ADJUST_PC(1); + + case INST_DUP: + valuePtr = stackPtr[stackTop].o; + PUSH_OBJECT(Tcl_DuplicateObj(valuePtr)); + TRACE_WITH_OBJ(("dup => "), valuePtr); + ADJUST_PC(1); + + case INST_CONCAT1: + opnd = TclGetUInt1AtPtr(pc+1); + { + Tcl_Obj *concatObjPtr; + int totalLen = 0; + + /* + * Concatenate strings (with no separators) from the top + * opnd items on the stack starting with the deepest item. + * First, determine how many characters are needed. + */ + + for (i = (stackTop - (opnd-1)); i <= stackTop; i++) { + valuePtr = stackPtr[i].o; + bytes = TclGetStringFromObj(valuePtr, &length); + if (bytes != NULL) { + totalLen += length; + } + } + + /* + * Initialize the new append string object by appending the + * strings of the opnd stack objects. Also pop the objects. + */ + + TclNewObj(concatObjPtr); + if (totalLen > 0) { + char *p = (char *) ckalloc((unsigned) (totalLen + 1)); + concatObjPtr->bytes = p; + concatObjPtr->length = totalLen; + for (i = (stackTop - (opnd-1)); i <= stackTop; i++) { + valuePtr = stackPtr[i].o; + bytes = TclGetStringFromObj(valuePtr, &length); + if (bytes != NULL) { + memcpy((VOID *) p, (VOID *) bytes, + (size_t) length); + p += length; + } + TclDecrRefCount(valuePtr); + } + *p = '\0'; + } else { + for (i = (stackTop - (opnd-1)); i <= stackTop; i++) { + valuePtr = stackPtr[i].o; + Tcl_DecrRefCount(valuePtr); + } + } + stackTop -= opnd; + + PUSH_OBJECT(concatObjPtr); + TRACE_WITH_OBJ(("concat %u => ", opnd), concatObjPtr); + ADJUST_PC(2); + } + + case INST_INVOKE_STK4: + opnd = TclGetUInt4AtPtr(pc+1); + pcAdjustment = 5; + goto doInvocation; + + case INST_INVOKE_STK1: + opnd = TclGetUInt1AtPtr(pc+1); + pcAdjustment = 2; + + doInvocation: + { + char *cmdName; + Command *cmdPtr; /* Points to command's Command struct. */ + int objc = opnd; /* The number of arguments. */ + Tcl_Obj **objv; /* The array of argument objects. */ + Tcl_Obj *objv0Ptr; /* Holds objv[0], the command name. */ + int newPcOffset = 0; + /* Instruction offset computed during + * break, continue, error processing. + * Init. to avoid compiler warning. */ + Tcl_Command cmd; +#ifdef TCL_COMPILE_DEBUG + int isUnknownCmd = 0; + char cmdNameBuf[30]; +#endif /* TCL_COMPILE_DEBUG */ + + /* + * If the interpreter was deleted, return an error. + */ + + if (iPtr->flags & DELETED) { + Tcl_ResetResult(interp); + Tcl_AppendToObj(Tcl_GetObjResult(interp), + "attempt to call eval in deleted interpreter", -1); + Tcl_SetErrorCode(interp, "CORE", "IDELETE", + "attempt to call eval in deleted interpreter", + (char *) NULL); + result = TCL_ERROR; + goto checkForCatch; + } + + objv = &(stackPtr[stackTop - (objc-1)].o); + objv0Ptr = objv[0]; + cmdName = TclGetStringFromObj(objv0Ptr, (int *) NULL); + + /* + * Find the procedure to execute this command. If there + * isn't one, then see if there is a command "unknown". If + * so, invoke it, passing it the original command words as + * arguments. + * + * We convert the objv[0] object to be a CmdName object. + * This caches a pointer to the Command structure for the + * command; this pointer is held in a ResolvedCmdName + * structure the object's internal rep. points to. + */ + + cmd = Tcl_GetCommandFromObj(interp, objv0Ptr); + cmdPtr = (Command *) cmd; + + /* + * If the command is still not found, handle it with the + * "unknown" proc. + */ + + if (cmdPtr == NULL) { + cmd = Tcl_FindCommand(interp, "unknown", + (Tcl_Namespace *) NULL, /*flags*/ TCL_GLOBAL_ONLY); + if (cmd == (Tcl_Command) NULL) { + Tcl_ResetResult(interp); + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "invalid command name \"", cmdName, "\"", + (char *) NULL); + TRACE(("%s %u => unknown proc not found: ", + opName[opCode], objc)); + result = TCL_ERROR; + goto checkForCatch; + } + cmdPtr = (Command *) cmd; +#ifdef TCL_COMPILE_DEBUG + isUnknownCmd = 1; +#endif /*TCL_COMPILE_DEBUG*/ + stackTop++; /* need room for new inserted objv[0] */ + for (i = objc; i >= 0; i--) { + objv[i+1] = objv[i]; + } + objc++; + objv[0] = Tcl_NewStringObj("unknown", -1); + Tcl_IncrRefCount(objv[0]); + } + + /* + * Call any trace procedures. + */ + + if (iPtr->tracePtr != NULL) { + Trace *tracePtr, *nextTracePtr; + + for (tracePtr = iPtr->tracePtr; tracePtr != NULL; + tracePtr = nextTracePtr) { + nextTracePtr = tracePtr->nextPtr; + if (iPtr->numLevels <= tracePtr->level) { + int numChars; + char *cmd = GetSrcInfoForPc(pc, codePtr, + &numChars); + if (cmd != NULL) { + DECACHE_STACK_INFO(); + CallTraceProcedure(interp, tracePtr, cmdPtr, + cmd, numChars, objc, objv); + CACHE_STACK_INFO(); + } + } + } + } + + /* + * Finally, invoke the command's Tcl_ObjCmdProc. First reset + * the interpreter's string and object results to their + * default empty values since they could have gotten changed + * by earlier invocations. + */ + + Tcl_ResetResult(interp); + + if (tclTraceExec >= 2) { + char buffer[50]; + + sprintf(buffer, "%d: (%u) invoking ", iPtr->numLevels, + (unsigned int)(pc - codePtr->codeStart)); + Tcl_DStringAppend(&command, buffer, -1); + +#ifdef TCL_COMPILE_DEBUG + if (traceInstructions) { /* tclTraceExec == 3 */ + strncpy(cmdNameBuf, cmdName, 20); + TRACE(("%s %u => call ", opName[opCode], + (isUnknownCmd? objc-1 : objc))); + } else { + fprintf(stdout, "%s", buffer); + } +#else /* TCL_COMPILE_DEBUG */ + fprintf(stdout, "%s", buffer); +#endif /*TCL_COMPILE_DEBUG*/ + + for (i = 0; i < objc; i++) { + bytes = TclGetStringFromObj(objv[i], &length); + TclPrintSource(stdout, bytes, TclMin(length, 15)); + fprintf(stdout, " "); + + sprintf(buffer, "\"%.*s\" ", TclMin(length, 15), bytes); + Tcl_DStringAppend(&command, buffer, -1); + } + fprintf(stdout, "\n"); + fflush(stdout); + + Tcl_DStringFree(&command); + } + + iPtr->cmdCount++; + DECACHE_STACK_INFO(); + result = (*cmdPtr->objProc)(cmdPtr->objClientData, interp, + objc, objv); + if (Tcl_AsyncReady()) { + result = Tcl_AsyncInvoke(interp, result); + } + CACHE_STACK_INFO(); + + /* + * If the interpreter has a non-empty string result, the + * result object is either empty or stale because some + * procedure set interp->result directly. If so, move the + * string result to the result object, then reset the + * string result. + */ + + if (*(iPtr->result) != 0) { + (void) Tcl_GetObjResult(interp); + } + + /* + * Pop the objc top stack elements and decrement their ref + * counts. + */ + + i = (stackTop - (objc-1)); + while (i <= stackTop) { + valuePtr = stackPtr[i].o; + TclDecrRefCount(valuePtr); + i++; + } + stackTop -= objc; + + /* + * Process the result of the Tcl_ObjCmdProc call. + */ + + switch (result) { + case TCL_OK: + /* + * Push the call's object result and continue execution + * with the next instruction. + */ + PUSH_OBJECT(Tcl_GetObjResult(interp)); + TRACE_WITH_OBJ(("%s %u => ...after \"%.20s\", result=", + opName[opCode], objc, cmdNameBuf), + Tcl_GetObjResult(interp)); + ADJUST_PC(pcAdjustment); + + case TCL_BREAK: + case TCL_CONTINUE: + /* + * The invoked command requested a break or continue. + * Find the closest enclosing loop or catch exception + * range, if any. If a loop is found, terminate its + * execution or skip to its next iteration. If the + * closest is a catch exception range, jump to its + * catchOffset. If no enclosing range is found, stop + * execution and return the TCL_BREAK or TCL_CONTINUE. + */ + rangePtr = TclGetExceptionRangeForPc(pc, + /*catchOnly*/ 0, codePtr); + if (rangePtr == NULL) { + TRACE(("%s %u => ... after \"%.20s\", no encl. loop or catch, returning %s\n", + opName[opCode], objc, cmdNameBuf, + StringForResultCode(result))); + goto abnormalReturn; /* no catch exists to check */ + } + switch (rangePtr->type) { + case LOOP_EXCEPTION_RANGE: + if (result == TCL_BREAK) { + newPcOffset = rangePtr->breakOffset; + } else if (rangePtr->continueOffset == -1) { + TRACE(("%s %u => ... after \"%.20s\", %s, loop w/o continue, checking for catch\n", + opName[opCode], objc, cmdNameBuf, + StringForResultCode(result))); + goto checkForCatch; + } else { + newPcOffset = rangePtr->continueOffset; + } + TRACE(("%s %u => ... after \"%.20s\", %s, range at %d, new pc %d\n", + opName[opCode], objc, cmdNameBuf, + StringForResultCode(result), + rangePtr->codeOffset, newPcOffset)); + break; + case CATCH_EXCEPTION_RANGE: + TRACE(("%s %u => ... after \"%.20s\", %s...\n", + opName[opCode], objc, cmdNameBuf, + StringForResultCode(result))); + goto processCatch; /* it will use rangePtr */ + default: + panic("TclExecuteByteCode: unrecognized ExceptionRange type %d\n", rangePtr->type); + } + result = TCL_OK; + pc = (codePtr->codeStart + newPcOffset); + continue; /* restart outer instruction loop at pc */ + + case TCL_ERROR: + /* + * The invoked command returned an error. Look for an + * enclosing catch exception range, if any. + */ + TRACE_WITH_OBJ(("%s %u => ... after \"%.20s\", TCL_ERROR ", + opName[opCode], objc, cmdNameBuf), + Tcl_GetObjResult(interp)); + goto checkForCatch; + + case TCL_RETURN: + /* + * The invoked command requested that the current + * procedure stop execution and return. First check + * for an enclosing catch exception range, if any. + */ + TRACE(("%s %u => ... after \"%.20s\", TCL_RETURN\n", + opName[opCode], objc, cmdNameBuf)); + goto checkForCatch; + + default: + TRACE_WITH_OBJ(("%s %u => ... after \"%.20s\", OTHER RETURN CODE %d ", + opName[opCode], objc, cmdNameBuf, result), + Tcl_GetObjResult(interp)); + goto checkForCatch; + } /* end of switch on result from invoke instruction */ + } + + case INST_EVAL_STK: + objPtr = POP_OBJECT(); + DECACHE_STACK_INFO(); + result = Tcl_EvalObj(interp, objPtr); + CACHE_STACK_INFO(); + if (result == TCL_OK) { + /* + * Normal return; push the eval's object result. + */ + + PUSH_OBJECT(Tcl_GetObjResult(interp)); + TRACE_WITH_OBJ(("evalStk \"%.30s\" => ", O2S(objPtr)), + Tcl_GetObjResult(interp)); + TclDecrRefCount(objPtr); + ADJUST_PC(1); + } else if ((result == TCL_BREAK) || (result == TCL_CONTINUE)) { + /* + * Find the closest enclosing loop or catch exception range, + * if any. If a loop is found, terminate its execution or + * skip to its next iteration. If the closest is a catch + * exception range, jump to its catchOffset. If no enclosing + * range is found, stop execution and return that same + * TCL_BREAK or TCL_CONTINUE. + */ + + int newPcOffset = 0; /* Pc offset computed during break, + * continue, error processing. Init. + * to avoid compiler warning. */ + + rangePtr = TclGetExceptionRangeForPc(pc, /*catchOnly*/ 0, + codePtr); + if (rangePtr == NULL) { + TRACE(("evalStk \"%.30s\" => no encl. loop or catch, returning %s\n", + O2S(objPtr), StringForResultCode(result))); + Tcl_DecrRefCount(objPtr); + goto abnormalReturn; /* no catch exists to check */ + } + switch (rangePtr->type) { + case LOOP_EXCEPTION_RANGE: + if (result == TCL_BREAK) { + newPcOffset = rangePtr->breakOffset; + } else if (rangePtr->continueOffset == -1) { + TRACE(("evalStk \"%.30s\" => %s, loop w/o continue, checking for catch\n", + O2S(objPtr), StringForResultCode(result))); + Tcl_DecrRefCount(objPtr); + goto checkForCatch; + } else { + newPcOffset = rangePtr->continueOffset; + } + result = TCL_OK; + TRACE_WITH_OBJ(("evalStk \"%.30s\" => %s, range at %d, new pc %d ", + O2S(objPtr), StringForResultCode(result), + rangePtr->codeOffset, newPcOffset), valuePtr); + break; + case CATCH_EXCEPTION_RANGE: + TRACE_WITH_OBJ(("evalStk \"%.30s\" => %s ", + O2S(objPtr), StringForResultCode(result)), + valuePtr); + Tcl_DecrRefCount(objPtr); + goto processCatch; /* it will use rangePtr */ + default: + panic("TclExecuteByteCode: unrecognized ExceptionRange type %d\n", rangePtr->type); + } + Tcl_DecrRefCount(objPtr); + pc = (codePtr->codeStart + newPcOffset); + continue; /* restart outer instruction loop at pc */ + } else { /* eval returned TCL_ERROR, TCL_RETURN, unknown code */ + TRACE_WITH_OBJ(("evalStk \"%.30s\" => ERROR: ", O2S(objPtr)), + Tcl_GetObjResult(interp)); + Tcl_DecrRefCount(objPtr); + goto checkForCatch; + } + + case INST_EXPR_STK: + objPtr = POP_OBJECT(); + Tcl_ResetResult(interp); + DECACHE_STACK_INFO(); + result = Tcl_ExprObj(interp, objPtr, &valuePtr); + CACHE_STACK_INFO(); + if (result != TCL_OK) { + TRACE_WITH_OBJ(("exprStk \"%.30s\" => ERROR: ", + O2S(objPtr)), Tcl_GetObjResult(interp)); + Tcl_DecrRefCount(objPtr); + goto checkForCatch; + } + stackPtr[++stackTop].o = valuePtr; /* already has right refct */ + TRACE_WITH_OBJ(("exprStk \"%.30s\" => ", O2S(objPtr)), valuePtr); + TclDecrRefCount(objPtr); + ADJUST_PC(1); + + case INST_LOAD_SCALAR4: + opnd = TclGetInt4AtPtr(pc+1); + pcAdjustment = 5; + goto doLoadScalar; + + case INST_LOAD_SCALAR1: + opnd = TclGetUInt1AtPtr(pc+1); + pcAdjustment = 2; + + doLoadScalar: + DECACHE_STACK_INFO(); + valuePtr = TclGetIndexedScalar(interp, opnd, + /*leaveErrorMsg*/ 1); + CACHE_STACK_INFO(); + if (valuePtr == NULL) { + TRACE_WITH_OBJ(("%s %u => ERROR: ", opName[opCode], opnd), + Tcl_GetObjResult(interp)); + result = TCL_ERROR; + goto checkForCatch; + } + PUSH_OBJECT(valuePtr); + TRACE_WITH_OBJ(("%s %u => ", opName[opCode], opnd), valuePtr); + ADJUST_PC(pcAdjustment); + + case INST_LOAD_SCALAR_STK: + namePtr = POP_OBJECT(); + DECACHE_STACK_INFO(); + valuePtr = Tcl_ObjGetVar2(interp, namePtr, (Tcl_Obj *) NULL, + TCL_LEAVE_ERR_MSG); + CACHE_STACK_INFO(); + if (valuePtr == NULL) { + TRACE_WITH_OBJ(("loadScalarStk \"%.30s\" => ERROR: ", + O2S(namePtr)), Tcl_GetObjResult(interp)); + Tcl_DecrRefCount(namePtr); + result = TCL_ERROR; + goto checkForCatch; + } + PUSH_OBJECT(valuePtr); + TRACE_WITH_OBJ(("loadScalarStk \"%.30s\" => ", + O2S(namePtr)), valuePtr); + TclDecrRefCount(namePtr); + ADJUST_PC(1); + + case INST_LOAD_ARRAY4: + opnd = TclGetUInt4AtPtr(pc+1); + pcAdjustment = 5; + goto doLoadArray; + + case INST_LOAD_ARRAY1: + opnd = TclGetUInt1AtPtr(pc+1); + pcAdjustment = 2; + + doLoadArray: + { + Tcl_Obj *elemPtr = POP_OBJECT(); + + DECACHE_STACK_INFO(); + valuePtr = TclGetElementOfIndexedArray(interp, opnd, + elemPtr, /*leaveErrorMsg*/ 1); + CACHE_STACK_INFO(); + if (valuePtr == NULL) { + TRACE_WITH_OBJ(("%s %u \"%.30s\" => ERROR: ", + opName[opCode], opnd, O2S(elemPtr)), + Tcl_GetObjResult(interp)); + Tcl_DecrRefCount(elemPtr); + result = TCL_ERROR; + goto checkForCatch; + } + PUSH_OBJECT(valuePtr); + TRACE_WITH_OBJ(("%s %u \"%.30s\" => ", + opName[opCode], opnd, O2S(elemPtr)), valuePtr); + TclDecrRefCount(elemPtr); + } + ADJUST_PC(pcAdjustment); + + case INST_LOAD_ARRAY_STK: + { + Tcl_Obj *elemPtr = POP_OBJECT(); + + namePtr = POP_OBJECT(); + DECACHE_STACK_INFO(); + valuePtr = Tcl_ObjGetVar2(interp, namePtr, elemPtr, + TCL_LEAVE_ERR_MSG); + CACHE_STACK_INFO(); + if (valuePtr == NULL) { + TRACE_WITH_OBJ(("loadArrayStk \"%.30s(%.30s)\" => ERROR: ", + O2S(namePtr), O2S(elemPtr)), + Tcl_GetObjResult(interp)); + Tcl_DecrRefCount(namePtr); + Tcl_DecrRefCount(elemPtr); + result = TCL_ERROR; + goto checkForCatch; + } + PUSH_OBJECT(valuePtr); + TRACE_WITH_OBJ(("loadArrayStk \"%.30s(%.30s)\" => ", + O2S(namePtr), O2S(elemPtr)), valuePtr); + TclDecrRefCount(namePtr); + TclDecrRefCount(elemPtr); + } + ADJUST_PC(1); + + case INST_LOAD_STK: + namePtr = POP_OBJECT(); + DECACHE_STACK_INFO(); + valuePtr = Tcl_ObjGetVar2(interp, namePtr, NULL, + TCL_PARSE_PART1|TCL_LEAVE_ERR_MSG); + CACHE_STACK_INFO(); + if (valuePtr == NULL) { + TRACE_WITH_OBJ(("loadStk \"%.30s\" => ERROR: ", + O2S(namePtr)), Tcl_GetObjResult(interp)); + Tcl_DecrRefCount(namePtr); + result = TCL_ERROR; + goto checkForCatch; + } + PUSH_OBJECT(valuePtr); + TRACE_WITH_OBJ(("loadStk \"%.30s\" => ", O2S(namePtr)), + valuePtr); + TclDecrRefCount(namePtr); + ADJUST_PC(1); + + case INST_STORE_SCALAR4: + opnd = TclGetUInt4AtPtr(pc+1); + pcAdjustment = 5; + goto doStoreScalar; + + case INST_STORE_SCALAR1: + opnd = TclGetUInt1AtPtr(pc+1); + pcAdjustment = 2; + + doStoreScalar: + valuePtr = POP_OBJECT(); + DECACHE_STACK_INFO(); + value2Ptr = TclSetIndexedScalar(interp, opnd, valuePtr, + /*leaveErrorMsg*/ 1); + CACHE_STACK_INFO(); + if (value2Ptr == NULL) { + TRACE_WITH_OBJ(("%s %u <- \"%.30s\" => ERROR: ", + opName[opCode], opnd, O2S(valuePtr)), + Tcl_GetObjResult(interp)); + Tcl_DecrRefCount(valuePtr); + result = TCL_ERROR; + goto checkForCatch; + } + PUSH_OBJECT(value2Ptr); + TRACE_WITH_OBJ(("%s %u <- \"%.30s\" => ", + opName[opCode], opnd, O2S(valuePtr)), value2Ptr); + TclDecrRefCount(valuePtr); + ADJUST_PC(pcAdjustment); + + case INST_STORE_SCALAR_STK: + valuePtr = POP_OBJECT(); + namePtr = POP_OBJECT(); + DECACHE_STACK_INFO(); + value2Ptr = Tcl_ObjSetVar2(interp, namePtr, NULL, valuePtr, + TCL_LEAVE_ERR_MSG); + CACHE_STACK_INFO(); + if (value2Ptr == NULL) { + TRACE_WITH_OBJ( + ("storeScalarStk \"%.30s\" <- \"%.30s\" => ERROR: ", + O2S(namePtr), O2S(valuePtr)), + Tcl_GetObjResult(interp)); + Tcl_DecrRefCount(namePtr); + Tcl_DecrRefCount(valuePtr); + result = TCL_ERROR; + goto checkForCatch; + } + PUSH_OBJECT(value2Ptr); + TRACE_WITH_OBJ( + ("storeScalarStk \"%.30s\" <- \"%.30s\" => ", + O2S(namePtr), + O2S(valuePtr)), + value2Ptr); + TclDecrRefCount(namePtr); + TclDecrRefCount(valuePtr); + ADJUST_PC(1); + + case INST_STORE_ARRAY4: + opnd = TclGetUInt4AtPtr(pc+1); + pcAdjustment = 5; + goto doStoreArray; + + case INST_STORE_ARRAY1: + opnd = TclGetUInt1AtPtr(pc+1); + pcAdjustment = 2; + + doStoreArray: + { + Tcl_Obj *elemPtr; + + valuePtr = POP_OBJECT(); + elemPtr = POP_OBJECT(); + DECACHE_STACK_INFO(); + value2Ptr = TclSetElementOfIndexedArray(interp, opnd, + elemPtr, valuePtr, TCL_LEAVE_ERR_MSG); + CACHE_STACK_INFO(); + if (value2Ptr == NULL) { + TRACE_WITH_OBJ( + ("%s %u \"%.30s\" <- \"%.30s\" => ERROR: ", + opName[opCode], opnd, O2S(elemPtr), + O2S(valuePtr)), Tcl_GetObjResult(interp)); + Tcl_DecrRefCount(elemPtr); + Tcl_DecrRefCount(valuePtr); + result = TCL_ERROR; + goto checkForCatch; + } + PUSH_OBJECT(value2Ptr); + TRACE_WITH_OBJ(("%s %u \"%.30s\" <- \"%.30s\" => ", + opName[opCode], opnd, O2S(elemPtr), O2S(valuePtr)), + value2Ptr); + TclDecrRefCount(elemPtr); + TclDecrRefCount(valuePtr); + } + ADJUST_PC(pcAdjustment); + + case INST_STORE_ARRAY_STK: + { + Tcl_Obj *elemPtr; + + valuePtr = POP_OBJECT(); + elemPtr = POP_OBJECT(); + namePtr = POP_OBJECT(); + DECACHE_STACK_INFO(); + value2Ptr = Tcl_ObjSetVar2(interp, namePtr, elemPtr, + valuePtr, TCL_LEAVE_ERR_MSG); + CACHE_STACK_INFO(); + if (value2Ptr == NULL) { + TRACE_WITH_OBJ(("storeArrayStk \"%.30s(%.30s)\" <- \"%.30s\" => ERROR: ", + O2S(namePtr), O2S(elemPtr), O2S(valuePtr)), + Tcl_GetObjResult(interp)); + Tcl_DecrRefCount(namePtr); + Tcl_DecrRefCount(elemPtr); + Tcl_DecrRefCount(valuePtr); + result = TCL_ERROR; + goto checkForCatch; + } + PUSH_OBJECT(value2Ptr); + TRACE_WITH_OBJ(("storeArrayStk \"%.30s(%.30s)\" <- \"%.30s\" => ", + O2S(namePtr), O2S(elemPtr), O2S(valuePtr)), + value2Ptr); + TclDecrRefCount(namePtr); + TclDecrRefCount(elemPtr); + TclDecrRefCount(valuePtr); + } + ADJUST_PC(1); + + case INST_STORE_STK: + valuePtr = POP_OBJECT(); + namePtr = POP_OBJECT(); + DECACHE_STACK_INFO(); + value2Ptr = Tcl_ObjSetVar2(interp, namePtr, NULL, valuePtr, + TCL_PARSE_PART1|TCL_LEAVE_ERR_MSG); + CACHE_STACK_INFO(); + if (value2Ptr == NULL) { + TRACE_WITH_OBJ(("storeStk \"%.30s\" <- \"%.30s\" => ERROR: ", + O2S(namePtr), O2S(valuePtr)), + Tcl_GetObjResult(interp)); + Tcl_DecrRefCount(namePtr); + Tcl_DecrRefCount(valuePtr); + result = TCL_ERROR; + goto checkForCatch; + } + PUSH_OBJECT(value2Ptr); + TRACE_WITH_OBJ(("storeStk \"%.30s\" <- \"%.30s\" => ", + O2S(namePtr), O2S(valuePtr)), value2Ptr); + TclDecrRefCount(namePtr); + TclDecrRefCount(valuePtr); + ADJUST_PC(1); + + case INST_INCR_SCALAR1: + opnd = TclGetUInt1AtPtr(pc+1); + valuePtr = POP_OBJECT(); + if (valuePtr->typePtr != &tclIntType) { + result = tclIntType.setFromAnyProc(interp, valuePtr); + if (result != TCL_OK) { + TRACE_WITH_OBJ(("incrScalar1 %u (by %s) => ERROR converting increment amount to int: ", + opnd, O2S(valuePtr)), Tcl_GetObjResult(interp)); + Tcl_DecrRefCount(valuePtr); + goto checkForCatch; + } + } + i = valuePtr->internalRep.longValue; + DECACHE_STACK_INFO(); + value2Ptr = TclIncrIndexedScalar(interp, opnd, i); + CACHE_STACK_INFO(); + if (value2Ptr == NULL) { + TRACE_WITH_OBJ(("incrScalar1 %u (by %ld) => ERROR: ", + opnd, i), Tcl_GetObjResult(interp)); + Tcl_DecrRefCount(valuePtr); + result = TCL_ERROR; + goto checkForCatch; + } + PUSH_OBJECT(value2Ptr); + TRACE_WITH_OBJ(("incrScalar1 %u (by %ld) => ", opnd, i), + value2Ptr); + TclDecrRefCount(valuePtr); + ADJUST_PC(2); + + case INST_INCR_SCALAR_STK: + case INST_INCR_STK: + valuePtr = POP_OBJECT(); + namePtr = POP_OBJECT(); + if (valuePtr->typePtr != &tclIntType) { + result = tclIntType.setFromAnyProc(interp, valuePtr); + if (result != TCL_OK) { + TRACE_WITH_OBJ(("%s \"%.30s\" (by %s) => ERROR converting increment amount to int: ", + opName[opCode], O2S(namePtr), O2S(valuePtr)), + Tcl_GetObjResult(interp)); + Tcl_DecrRefCount(namePtr); + Tcl_DecrRefCount(valuePtr); + goto checkForCatch; + } + } + i = valuePtr->internalRep.longValue; + DECACHE_STACK_INFO(); + value2Ptr = TclIncrVar2(interp, namePtr, (Tcl_Obj *) NULL, i, + /*part1NotParsed*/ (opCode == INST_INCR_STK)); + CACHE_STACK_INFO(); + if (value2Ptr == NULL) { + TRACE_WITH_OBJ(("%s \"%.30s\" (by %ld) => ERROR: ", + opName[opCode], O2S(namePtr), i), + Tcl_GetObjResult(interp)); + Tcl_DecrRefCount(namePtr); + Tcl_DecrRefCount(valuePtr); + result = TCL_ERROR; + goto checkForCatch; + } + PUSH_OBJECT(value2Ptr); + TRACE_WITH_OBJ(("%s \"%.30s\" (by %ld) => ", + opName[opCode], O2S(namePtr), i), value2Ptr); + Tcl_DecrRefCount(namePtr); + Tcl_DecrRefCount(valuePtr); + ADJUST_PC(1); + + case INST_INCR_ARRAY1: + { + Tcl_Obj *elemPtr; + + opnd = TclGetUInt1AtPtr(pc+1); + valuePtr = POP_OBJECT(); + elemPtr = POP_OBJECT(); + if (valuePtr->typePtr != &tclIntType) { + result = tclIntType.setFromAnyProc(interp, valuePtr); + if (result != TCL_OK) { + TRACE_WITH_OBJ(("incrArray1 %u \"%.30s\" (by %s) => ERROR converting increment amount to int: ", + opnd, O2S(elemPtr), O2S(valuePtr)), + Tcl_GetObjResult(interp)); + Tcl_DecrRefCount(elemPtr); + Tcl_DecrRefCount(valuePtr); + goto checkForCatch; + } + } + i = valuePtr->internalRep.longValue; + DECACHE_STACK_INFO(); + value2Ptr = TclIncrElementOfIndexedArray(interp, opnd, + elemPtr, i); + CACHE_STACK_INFO(); + if (value2Ptr == NULL) { + TRACE_WITH_OBJ(("incrArray1 %u \"%.30s\" (by %ld) => ERROR: ", + opnd, O2S(elemPtr), i), + Tcl_GetObjResult(interp)); + Tcl_DecrRefCount(elemPtr); + Tcl_DecrRefCount(valuePtr); + result = TCL_ERROR; + goto checkForCatch; + } + PUSH_OBJECT(value2Ptr); + TRACE_WITH_OBJ(("incrArray1 %u \"%.30s\" (by %ld) => ", + opnd, O2S(elemPtr), i), value2Ptr); + Tcl_DecrRefCount(elemPtr); + Tcl_DecrRefCount(valuePtr); + } + ADJUST_PC(2); + + case INST_INCR_ARRAY_STK: + { + Tcl_Obj *elemPtr; + + valuePtr = POP_OBJECT(); + elemPtr = POP_OBJECT(); + namePtr = POP_OBJECT(); + if (valuePtr->typePtr != &tclIntType) { + result = tclIntType.setFromAnyProc(interp, valuePtr); + if (result != TCL_OK) { + TRACE_WITH_OBJ(("incrArrayStk \"%.30s(%.30s)\" (by %s) => ERROR converting increment amount to int: ", + O2S(namePtr), O2S(elemPtr), O2S(valuePtr)), + Tcl_GetObjResult(interp)); + Tcl_DecrRefCount(namePtr); + Tcl_DecrRefCount(elemPtr); + Tcl_DecrRefCount(valuePtr); + goto checkForCatch; + } + } + i = valuePtr->internalRep.longValue; + DECACHE_STACK_INFO(); + value2Ptr = TclIncrVar2(interp, namePtr, elemPtr, i, + /*part1NotParsed*/ 0); + CACHE_STACK_INFO(); + if (value2Ptr == NULL) { + TRACE_WITH_OBJ(("incrArrayStk \"%.30s(%.30s)\" (by %ld) => ERROR: ", + O2S(namePtr), O2S(elemPtr), i), + Tcl_GetObjResult(interp)); + Tcl_DecrRefCount(namePtr); + Tcl_DecrRefCount(elemPtr); + Tcl_DecrRefCount(valuePtr); + result = TCL_ERROR; + goto checkForCatch; + } + PUSH_OBJECT(value2Ptr); + TRACE_WITH_OBJ(("incrArrayStk \"%.30s(%.30s)\" (by %ld) => ", + O2S(namePtr), O2S(elemPtr), i), value2Ptr); + Tcl_DecrRefCount(namePtr); + Tcl_DecrRefCount(elemPtr); + Tcl_DecrRefCount(valuePtr); + } + ADJUST_PC(1); + + case INST_INCR_SCALAR1_IMM: + opnd = TclGetUInt1AtPtr(pc+1); + i = TclGetInt1AtPtr(pc+2); + DECACHE_STACK_INFO(); + value2Ptr = TclIncrIndexedScalar(interp, opnd, i); + CACHE_STACK_INFO(); + if (value2Ptr == NULL) { + TRACE_WITH_OBJ(("incrScalar1Imm %u %ld => ERROR: ", + opnd, i), Tcl_GetObjResult(interp)); + result = TCL_ERROR; + goto checkForCatch; + } + PUSH_OBJECT(value2Ptr); + TRACE_WITH_OBJ(("incrScalar1Imm %u %ld => ", opnd, i), + value2Ptr); + ADJUST_PC(3); + + case INST_INCR_SCALAR_STK_IMM: + case INST_INCR_STK_IMM: + namePtr = POP_OBJECT(); + i = TclGetInt1AtPtr(pc+1); + DECACHE_STACK_INFO(); + value2Ptr = TclIncrVar2(interp, namePtr, (Tcl_Obj *) NULL, i, + /*part1NotParsed*/ (opCode == INST_INCR_STK_IMM)); + CACHE_STACK_INFO(); + if (value2Ptr == NULL) { + TRACE_WITH_OBJ(("%s \"%.30s\" %ld => ERROR: ", + opName[opCode], O2S(namePtr), i), + Tcl_GetObjResult(interp)); + result = TCL_ERROR; + Tcl_DecrRefCount(namePtr); + goto checkForCatch; + } + PUSH_OBJECT(value2Ptr); + TRACE_WITH_OBJ(("%s \"%.30s\" %ld => ", + opName[opCode], O2S(namePtr), i), value2Ptr); + TclDecrRefCount(namePtr); + ADJUST_PC(2); + + case INST_INCR_ARRAY1_IMM: + { + Tcl_Obj *elemPtr; + + opnd = TclGetUInt1AtPtr(pc+1); + i = TclGetInt1AtPtr(pc+2); + elemPtr = POP_OBJECT(); + DECACHE_STACK_INFO(); + value2Ptr = TclIncrElementOfIndexedArray(interp, opnd, + elemPtr, i); + CACHE_STACK_INFO(); + if (value2Ptr == NULL) { + TRACE_WITH_OBJ(("incrArray1Imm %u \"%.30s\" (by %ld) => ERROR: ", + opnd, O2S(elemPtr), i), + Tcl_GetObjResult(interp)); + Tcl_DecrRefCount(elemPtr); + result = TCL_ERROR; + goto checkForCatch; + } + PUSH_OBJECT(value2Ptr); + TRACE_WITH_OBJ(("incrArray1Imm %u \"%.30s\" (by %ld) => ", + opnd, O2S(elemPtr), i), value2Ptr); + Tcl_DecrRefCount(elemPtr); + } + ADJUST_PC(3); + + case INST_INCR_ARRAY_STK_IMM: + { + Tcl_Obj *elemPtr; + + i = TclGetInt1AtPtr(pc+1); + elemPtr = POP_OBJECT(); + namePtr = POP_OBJECT(); + DECACHE_STACK_INFO(); + value2Ptr = TclIncrVar2(interp, namePtr, elemPtr, i, + /*part1NotParsed*/ 0); + CACHE_STACK_INFO(); + if (value2Ptr == NULL) { + TRACE_WITH_OBJ(("incrArrayStkImm \"%.30s(%.30s)\" (by %ld) => ERROR: ", + O2S(namePtr), O2S(elemPtr), i), + Tcl_GetObjResult(interp)); + Tcl_DecrRefCount(namePtr); + Tcl_DecrRefCount(elemPtr); + result = TCL_ERROR; + goto checkForCatch; + } + PUSH_OBJECT(value2Ptr); + TRACE_WITH_OBJ(("incrArrayStkImm \"%.30s(%.30s)\" (by %ld) => ", + O2S(namePtr), O2S(elemPtr), i), value2Ptr); + Tcl_DecrRefCount(namePtr); + Tcl_DecrRefCount(elemPtr); + } + ADJUST_PC(2); + + case INST_JUMP1: + opnd = TclGetInt1AtPtr(pc+1); + TRACE(("jump1 %d => new pc %u\n", opnd, + (unsigned int)(pc + opnd - codePtr->codeStart))); + ADJUST_PC(opnd); + + case INST_JUMP4: + opnd = TclGetInt4AtPtr(pc+1); + TRACE(("jump4 %d => new pc %u\n", opnd, + (unsigned int)(pc + opnd - codePtr->codeStart))); + ADJUST_PC(opnd); + + case INST_JUMP_TRUE4: + opnd = TclGetInt4AtPtr(pc+1); + pcAdjustment = 5; + goto doJumpTrue; + + case INST_JUMP_TRUE1: + opnd = TclGetInt1AtPtr(pc+1); + pcAdjustment = 2; + + doJumpTrue: + { + int b; + + valuePtr = POP_OBJECT(); + if (valuePtr->typePtr == &tclIntType) { + b = (valuePtr->internalRep.longValue != 0); + } else if (valuePtr->typePtr == &tclDoubleType) { + b = (valuePtr->internalRep.doubleValue != 0.0); + } else { + result = Tcl_GetBooleanFromObj(interp, valuePtr, &b); + if (result != TCL_OK) { + TRACE_WITH_OBJ(("%s %d => ERROR: ", opName[opCode], + opnd), Tcl_GetObjResult(interp)); + Tcl_DecrRefCount(valuePtr); + goto checkForCatch; + } + } + if (b) { + TRACE(("%s %d => %.20s true, new pc %u\n", + opName[opCode], opnd, O2S(valuePtr), + (unsigned int)(pc+opnd - codePtr->codeStart))); + TclDecrRefCount(valuePtr); + ADJUST_PC(opnd); + } else { + TRACE(("%s %d => %.20s false\n", opName[opCode], opnd, + O2S(valuePtr))); + TclDecrRefCount(valuePtr); + ADJUST_PC(pcAdjustment); + } + } + + case INST_JUMP_FALSE4: + opnd = TclGetInt4AtPtr(pc+1); + pcAdjustment = 5; + goto doJumpFalse; + + case INST_JUMP_FALSE1: + opnd = TclGetInt1AtPtr(pc+1); + pcAdjustment = 2; + + doJumpFalse: + { + int b; + + valuePtr = POP_OBJECT(); + if (valuePtr->typePtr == &tclIntType) { + b = (valuePtr->internalRep.longValue != 0); + } else if (valuePtr->typePtr == &tclDoubleType) { + b = (valuePtr->internalRep.doubleValue != 0.0); + } else { + result = Tcl_GetBooleanFromObj(interp, valuePtr, &b); + if (result != TCL_OK) { + TRACE_WITH_OBJ(("%s %d => ERROR: ", opName[opCode], + opnd), Tcl_GetObjResult(interp)); + Tcl_DecrRefCount(valuePtr); + goto checkForCatch; + } + } + if (b) { + TRACE(("%s %d => %.20s true\n", opName[opCode], opnd, + O2S(valuePtr))); + TclDecrRefCount(valuePtr); + ADJUST_PC(pcAdjustment); + } else { + TRACE(("%s %d => %.20s false, new pc %u\n", + opName[opCode], opnd, O2S(valuePtr), + (unsigned int)(pc + opnd - codePtr->codeStart))); + TclDecrRefCount(valuePtr); + ADJUST_PC(opnd); + } + } + + case INST_LOR: + case INST_LAND: + { + /* + * Operands must be boolean or numeric. No int->double + * conversions are performed. + */ + + int i1, i2; + int iResult; + char *s; + Tcl_ObjType *t1Ptr, *t2Ptr; + + value2Ptr = POP_OBJECT(); + valuePtr = POP_OBJECT(); + t1Ptr = valuePtr->typePtr; + t2Ptr = value2Ptr->typePtr; + + if ((t1Ptr == &tclIntType) || (t1Ptr == &tclBooleanType)) { + i1 = (valuePtr->internalRep.longValue != 0); + } else if (t1Ptr == &tclDoubleType) { + i1 = (valuePtr->internalRep.doubleValue != 0.0); + } else { /* FAILS IF NULL STRING REP */ + s = Tcl_GetStringFromObj(valuePtr, (int *) NULL); + if (TclLooksLikeInt(s)) { + result = Tcl_GetLongFromObj((Tcl_Interp *) NULL, + valuePtr, &i); + i1 = (i != 0); + } else { + result = Tcl_GetBooleanFromObj((Tcl_Interp *) NULL, + valuePtr, &i1); + i1 = (i1 != 0); + } + if (result != TCL_OK) { + TRACE(("%s \"%.20s\" => ILLEGAL TYPE %s \n", + opName[opCode], O2S(valuePtr), + (t1Ptr? t1Ptr->name : "null"))); + IllegalExprOperandType(interp, opCode, valuePtr); + Tcl_DecrRefCount(valuePtr); + Tcl_DecrRefCount(value2Ptr); + goto checkForCatch; + } + } + + if ((t2Ptr == &tclIntType) || (t2Ptr == &tclBooleanType)) { + i2 = (value2Ptr->internalRep.longValue != 0); + } else if (t2Ptr == &tclDoubleType) { + i2 = (value2Ptr->internalRep.doubleValue != 0.0); + } else { /* FAILS IF NULL STRING REP */ + s = Tcl_GetStringFromObj(value2Ptr, (int *) NULL); + if (TclLooksLikeInt(s)) { + result = Tcl_GetLongFromObj((Tcl_Interp *) NULL, + value2Ptr, &i); + i2 = (i != 0); + } else { + result = Tcl_GetBooleanFromObj((Tcl_Interp *) NULL, + value2Ptr, &i2); + i2 = (i2 != 0); + } + if (result != TCL_OK) { + TRACE(("%s \"%.20s\" => ILLEGAL TYPE %s \n", + opName[opCode], O2S(value2Ptr), + (t2Ptr? t2Ptr->name : "null"))); + IllegalExprOperandType(interp, opCode, value2Ptr); + Tcl_DecrRefCount(valuePtr); + Tcl_DecrRefCount(value2Ptr); + goto checkForCatch; + } + } + + /* + * Reuse the valuePtr object already on stack if possible. + */ + + if (opCode == INST_LOR) { + iResult = (i1 || i2); + } else { + iResult = (i1 && i2); + } + if (Tcl_IsShared(valuePtr)) { + PUSH_OBJECT(Tcl_NewLongObj(iResult)); + TRACE(("%s %.20s %.20s => %d\n", opName[opCode], + O2S(valuePtr), O2S(value2Ptr), iResult)); + TclDecrRefCount(valuePtr); + } else { /* reuse the valuePtr object */ + TRACE(("%s %.20s %.20s => %d\n", + opName[opCode], /* NB: stack top is off by 1 */ + O2S(valuePtr), O2S(value2Ptr), iResult)); + Tcl_SetLongObj(valuePtr, iResult); + ++stackTop; /* valuePtr now on stk top has right r.c. */ + } + TclDecrRefCount(value2Ptr); + } + ADJUST_PC(1); + + case INST_EQ: + case INST_NEQ: + case INST_LT: + case INST_GT: + case INST_LE: + case INST_GE: + { + /* + * Any type is allowed but the two operands must have the + * same type. We will compute value op value2. + */ + + Tcl_ObjType *t1Ptr, *t2Ptr; + char *s1 = NULL; /* Init. avoids compiler warning. */ + char *s2 = NULL; /* Init. avoids compiler warning. */ + long i2 = 0; /* Init. avoids compiler warning. */ + double d1 = 0.0; /* Init. avoids compiler warning. */ + double d2 = 0.0; /* Init. avoids compiler warning. */ + long iResult = 0; /* Init. avoids compiler warning. */ + + value2Ptr = POP_OBJECT(); + valuePtr = POP_OBJECT(); + t1Ptr = valuePtr->typePtr; + t2Ptr = value2Ptr->typePtr; + + if ((t1Ptr != &tclIntType) && (t1Ptr != &tclDoubleType)) { + s1 = Tcl_GetStringFromObj(valuePtr, &length); + if (TclLooksLikeInt(s1)) { /* FAILS IF NULLS */ + (void) Tcl_GetLongFromObj((Tcl_Interp *) NULL, + valuePtr, &i); + } else { + (void) Tcl_GetDoubleFromObj((Tcl_Interp *) NULL, + valuePtr, &d1); + } + t1Ptr = valuePtr->typePtr; + } + if ((t2Ptr != &tclIntType) && (t2Ptr != &tclDoubleType)) { + s2 = Tcl_GetStringFromObj(value2Ptr, &length); + if (TclLooksLikeInt(s2)) { /* FAILS IF NULLS */ + (void) Tcl_GetLongFromObj((Tcl_Interp *) NULL, + value2Ptr, &i2); + } else { + (void) Tcl_GetDoubleFromObj((Tcl_Interp *) NULL, + value2Ptr, &d2); + } + t2Ptr = value2Ptr->typePtr; + } + + if (((t1Ptr != &tclIntType) && (t1Ptr != &tclDoubleType)) + || ((t2Ptr != &tclIntType) && (t2Ptr != &tclDoubleType))) { + /* + * One operand is not numeric. Compare as strings. + * THIS FAILS IF AN OBJECT'S STRING REP CONTAINS NULLS. + */ + int cmpValue; + s1 = TclGetStringFromObj(valuePtr, &length); + s2 = TclGetStringFromObj(value2Ptr, &length); + cmpValue = strcmp(s1, s2); + switch (opCode) { + case INST_EQ: + iResult = (cmpValue == 0); + break; + case INST_NEQ: + iResult = (cmpValue != 0); + break; + case INST_LT: + iResult = (cmpValue < 0); + break; + case INST_GT: + iResult = (cmpValue > 0); + break; + case INST_LE: + iResult = (cmpValue <= 0); + break; + case INST_GE: + iResult = (cmpValue >= 0); + break; + } + } else if ((t1Ptr == &tclDoubleType) + || (t2Ptr == &tclDoubleType)) { + /* + * Compare as doubles. + */ + if (t1Ptr == &tclDoubleType) { + d1 = valuePtr->internalRep.doubleValue; + if (t2Ptr == &tclIntType) { + d2 = value2Ptr->internalRep.longValue; + } else { + d2 = value2Ptr->internalRep.doubleValue; + } + } else { /* t1Ptr is int, t2Ptr is double */ + d1 = valuePtr->internalRep.longValue; + d2 = value2Ptr->internalRep.doubleValue; + } + switch (opCode) { + case INST_EQ: + iResult = d1 == d2; + break; + case INST_NEQ: + iResult = d1 != d2; + break; + case INST_LT: + iResult = d1 < d2; + break; + case INST_GT: + iResult = d1 > d2; + break; + case INST_LE: + iResult = d1 <= d2; + break; + case INST_GE: + iResult = d1 >= d2; + break; + } + } else { + /* + * Compare as ints. + */ + i = valuePtr->internalRep.longValue; + i2 = value2Ptr->internalRep.longValue; + switch (opCode) { + case INST_EQ: + iResult = i == i2; + break; + case INST_NEQ: + iResult = i != i2; + break; + case INST_LT: + iResult = i < i2; + break; + case INST_GT: + iResult = i > i2; + break; + case INST_LE: + iResult = i <= i2; + break; + case INST_GE: + iResult = i >= i2; + break; + } + } + + /* + * Reuse the valuePtr object already on stack if possible. + */ + + if (Tcl_IsShared(valuePtr)) { + PUSH_OBJECT(Tcl_NewLongObj(iResult)); + TRACE(("%s %.20s %.20s => %ld\n", opName[opCode], + O2S(valuePtr), O2S(value2Ptr), iResult)); + TclDecrRefCount(valuePtr); + } else { /* reuse the valuePtr object */ + TRACE(("%s %.20s %.20s => %ld\n", + opName[opCode], /* NB: stack top is off by 1 */ + O2S(valuePtr), O2S(value2Ptr), iResult)); + Tcl_SetLongObj(valuePtr, iResult); + ++stackTop; /* valuePtr now on stk top has right r.c. */ + } + TclDecrRefCount(value2Ptr); + } + ADJUST_PC(1); + + case INST_MOD: + case INST_LSHIFT: + case INST_RSHIFT: + case INST_BITOR: + case INST_BITXOR: + case INST_BITAND: + { + /* + * Only integers are allowed. We compute value op value2. + */ + + long i2, rem, negative; + long iResult = 0; /* Init. avoids compiler warning. */ + + value2Ptr = POP_OBJECT(); + valuePtr = POP_OBJECT(); + if (valuePtr->typePtr == &tclIntType) { + i = valuePtr->internalRep.longValue; + } else { /* try to convert to int */ + result = Tcl_GetLongFromObj((Tcl_Interp *) NULL, + valuePtr, &i); + if (result != TCL_OK) { + TRACE(("%s %.20s %.20s => ILLEGAL 1st TYPE %s\n", + opName[opCode], O2S(valuePtr), O2S(value2Ptr), + (valuePtr->typePtr? + valuePtr->typePtr->name : "null"))); + IllegalExprOperandType(interp, opCode, valuePtr); + Tcl_DecrRefCount(valuePtr); + Tcl_DecrRefCount(value2Ptr); + goto checkForCatch; + } + } + if (value2Ptr->typePtr == &tclIntType) { + i2 = value2Ptr->internalRep.longValue; + } else { + result = Tcl_GetLongFromObj((Tcl_Interp *) NULL, + value2Ptr, &i2); + if (result != TCL_OK) { + TRACE(("%s %.20s %.20s => ILLEGAL 2nd TYPE %s\n", + opName[opCode], O2S(valuePtr), O2S(value2Ptr), + (value2Ptr->typePtr? + value2Ptr->typePtr->name : "null"))); + IllegalExprOperandType(interp, opCode, value2Ptr); + Tcl_DecrRefCount(valuePtr); + Tcl_DecrRefCount(value2Ptr); + goto checkForCatch; + } + } + + switch (opCode) { + case INST_MOD: + /* + * This code is tricky: C doesn't guarantee much about + * the quotient or remainder, but Tcl does. The + * remainder always has the same sign as the divisor and + * a smaller absolute value. + */ + if (i2 == 0) { + TRACE(("mod %ld %ld => DIVIDE BY ZERO\n", i, i2)); + Tcl_DecrRefCount(valuePtr); + Tcl_DecrRefCount(value2Ptr); + goto divideByZero; + } + negative = 0; + if (i2 < 0) { + i2 = -i2; + i = -i; + negative = 1; + } + rem = i % i2; + if (rem < 0) { + rem += i2; + } + if (negative) { + rem = -rem; + } + iResult = rem; + break; + case INST_LSHIFT: + iResult = i << i2; + break; + case INST_RSHIFT: + /* + * The following code is a bit tricky: it ensures that + * right shifts propagate the sign bit even on machines + * where ">>" won't do it by default. + */ + if (i < 0) { + iResult = ~((~i) >> i2); + } else { + iResult = i >> i2; + } + break; + case INST_BITOR: + iResult = i | i2; + break; + case INST_BITXOR: + iResult = i ^ i2; + break; + case INST_BITAND: + iResult = i & i2; + break; + } + + /* + * Reuse the valuePtr object already on stack if possible. + */ + + if (Tcl_IsShared(valuePtr)) { + PUSH_OBJECT(Tcl_NewLongObj(iResult)); + TRACE(("%s %ld %ld => %ld\n", opName[opCode], i, i2, + iResult)); + TclDecrRefCount(valuePtr); + } else { /* reuse the valuePtr object */ + TRACE(("%s %ld %ld => %ld\n", opName[opCode], i, i2, + iResult)); /* NB: stack top is off by 1 */ + Tcl_SetLongObj(valuePtr, iResult); + ++stackTop; /* valuePtr now on stk top has right r.c. */ + } + TclDecrRefCount(value2Ptr); + } + ADJUST_PC(1); + + case INST_ADD: + case INST_SUB: + case INST_MULT: + case INST_DIV: + { + /* + * Operands must be numeric and ints get converted to floats + * if necessary. We compute value op value2. + */ + + Tcl_ObjType *t1Ptr, *t2Ptr; + long i2, quot, rem; + double d1, d2; + long iResult = 0; /* Init. avoids compiler warning. */ + double dResult = 0.0; /* Init. avoids compiler warning. */ + int doDouble = 0; /* 1 if doing floating arithmetic */ + + value2Ptr = POP_OBJECT(); + valuePtr = POP_OBJECT(); + t1Ptr = valuePtr->typePtr; + t2Ptr = value2Ptr->typePtr; + + if (t1Ptr == &tclIntType) { + i = valuePtr->internalRep.longValue; + } else if (t1Ptr == &tclDoubleType) { + d1 = valuePtr->internalRep.doubleValue; + } else { /* try to convert; FAILS IF NULLS */ + char *s = Tcl_GetStringFromObj(valuePtr, &length); + if (TclLooksLikeInt(s)) { + result = Tcl_GetLongFromObj((Tcl_Interp *) NULL, + valuePtr, &i); + } else { + result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL, + valuePtr, &d1); + } + if (result != TCL_OK) { + TRACE(("%s %.20s %.20s => ILLEGAL 1st TYPE %s\n", + opName[opCode], s, O2S(value2Ptr), + (valuePtr->typePtr? + valuePtr->typePtr->name : "null"))); + IllegalExprOperandType(interp, opCode, valuePtr); + Tcl_DecrRefCount(valuePtr); + Tcl_DecrRefCount(value2Ptr); + goto checkForCatch; + } + t1Ptr = valuePtr->typePtr; + } + + if (t2Ptr == &tclIntType) { + i2 = value2Ptr->internalRep.longValue; + } else if (t2Ptr == &tclDoubleType) { + d2 = value2Ptr->internalRep.doubleValue; + } else { /* try to convert; FAILS IF NULLS */ + char *s = Tcl_GetStringFromObj(value2Ptr, &length); + if (TclLooksLikeInt(s)) { + result = Tcl_GetLongFromObj((Tcl_Interp *) NULL, + value2Ptr, &i2); + } else { + result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL, + value2Ptr, &d2); + } + if (result != TCL_OK) { + TRACE(("%s %.20s %.20s => ILLEGAL 2nd TYPE %s\n", + opName[opCode], O2S(valuePtr), s, + (value2Ptr->typePtr? + value2Ptr->typePtr->name : "null"))); + IllegalExprOperandType(interp, opCode, value2Ptr); + Tcl_DecrRefCount(valuePtr); + Tcl_DecrRefCount(value2Ptr); + goto checkForCatch; + } + t2Ptr = value2Ptr->typePtr; + } + + if ((t1Ptr == &tclDoubleType) || (t2Ptr == &tclDoubleType)) { + /* + * Do double arithmetic. + */ + doDouble = 1; + if (t1Ptr == &tclIntType) { + d1 = i; /* promote value 1 to double */ + } else if (t2Ptr == &tclIntType) { + d2 = i2; /* promote value 2 to double */ + } + switch (opCode) { + case INST_ADD: + dResult = d1 + d2; + break; + case INST_SUB: + dResult = d1 - d2; + break; + case INST_MULT: + dResult = d1 * d2; + break; + case INST_DIV: + if (d2 == 0.0) { + TRACE(("div %.6g %.6g => DIVIDE BY ZERO\n", + d1, d2)); + Tcl_DecrRefCount(valuePtr); + Tcl_DecrRefCount(value2Ptr); + goto divideByZero; + } + dResult = d1 / d2; + break; + } + + /* + * Check now for IEEE floating-point error. + */ + + if (IS_NAN(dResult) || IS_INF(dResult)) { + TRACE(("%s %.20s %.20s => IEEE FLOATING PT ERROR\n", + opName[opCode], O2S(valuePtr), O2S(value2Ptr))); + TclExprFloatError(interp, dResult); + result = TCL_ERROR; + Tcl_DecrRefCount(valuePtr); + Tcl_DecrRefCount(value2Ptr); + goto checkForCatch; + } + } else { + /* + * Do integer arithmetic. + */ + switch (opCode) { + case INST_ADD: + iResult = i + i2; + break; + case INST_SUB: + iResult = i - i2; + break; + case INST_MULT: + iResult = i * i2; + break; + case INST_DIV: + /* + * This code is tricky: C doesn't guarantee much + * about the quotient or remainder, but Tcl does. + * The remainder always has the same sign as the + * divisor and a smaller absolute value. + */ + if (i2 == 0) { + TRACE(("div %ld %ld => DIVIDE BY ZERO\n", + i, i2)); + Tcl_DecrRefCount(valuePtr); + Tcl_DecrRefCount(value2Ptr); + goto divideByZero; + } + if (i2 < 0) { + i2 = -i2; + i = -i; + } + quot = i / i2; + rem = i % i2; + if (rem < 0) { + quot -= 1; + } + iResult = quot; + break; + } + } + + /* + * Reuse the valuePtr object already on stack if possible. + */ + + if (Tcl_IsShared(valuePtr)) { + if (doDouble) { + PUSH_OBJECT(Tcl_NewDoubleObj(dResult)); + TRACE(("%s %.6g %.6g => %.6g\n", opName[opCode], + d1, d2, dResult)); + } else { + PUSH_OBJECT(Tcl_NewLongObj(iResult)); + TRACE(("%s %ld %ld => %ld\n", opName[opCode], + i, i2, iResult)); + } + TclDecrRefCount(valuePtr); + } else { /* reuse the valuePtr object */ + if (doDouble) { /* NB: stack top is off by 1 */ + TRACE(("%s %.6g %.6g => %.6g\n", opName[opCode], + d1, d2, dResult)); + Tcl_SetDoubleObj(valuePtr, dResult); + } else { + TRACE(("%s %ld %ld => %ld\n", opName[opCode], + i, i2, iResult)); + Tcl_SetLongObj(valuePtr, iResult); + } + ++stackTop; /* valuePtr now on stk top has right r.c. */ + } + TclDecrRefCount(value2Ptr); + } + ADJUST_PC(1); + + case INST_UPLUS: + { + /* + * Operand must be numeric. + */ + + double d; + Tcl_ObjType *tPtr; + + valuePtr = stackPtr[stackTop].o; + tPtr = valuePtr->typePtr; + if ((tPtr != &tclIntType) && (tPtr != &tclDoubleType)) { + char *s = Tcl_GetStringFromObj(valuePtr, (int *) NULL); + if (TclLooksLikeInt(s)) { /* FAILS IF NULLS */ + result = Tcl_GetLongFromObj((Tcl_Interp *) NULL, + valuePtr, &i); + } else { + result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL, + valuePtr, &d); + } + if (result != TCL_OK) { + TRACE(("%s \"%.20s\" => ILLEGAL TYPE %s \n", + opName[opCode], s, + (tPtr? tPtr->name : "null"))); + IllegalExprOperandType(interp, opCode, valuePtr); + goto checkForCatch; + } + } + TRACE_WITH_OBJ(("uplus %s => ", O2S(valuePtr)), valuePtr); + } + ADJUST_PC(1); + + case INST_UMINUS: + case INST_LNOT: + { + /* + * The operand must be numeric. If the operand object is + * unshared modify it directly, otherwise create a copy to + * modify: this is "copy on write". free any old string + * representation since it is now invalid. + */ + + double d; + Tcl_ObjType *tPtr; + + valuePtr = POP_OBJECT(); + tPtr = valuePtr->typePtr; + if ((tPtr != &tclIntType) && (tPtr != &tclDoubleType)) { + char *s = Tcl_GetStringFromObj(valuePtr, (int *) NULL); + if (TclLooksLikeInt(s)) { /* FAILS IF NULLS */ + result = Tcl_GetLongFromObj((Tcl_Interp *) NULL, + valuePtr, &i); + } else { + result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL, + valuePtr, &d); + } + if (result != TCL_OK) { + TRACE(("%s \"%.20s\" => ILLEGAL TYPE %s\n", + opName[opCode], s, + (tPtr? tPtr->name : "null"))); + IllegalExprOperandType(interp, opCode, valuePtr); + Tcl_DecrRefCount(valuePtr); + goto checkForCatch; + } + tPtr = valuePtr->typePtr; + } + + if (Tcl_IsShared(valuePtr)) { + /* + * Create a new object. + */ + if (tPtr == &tclIntType) { + i = valuePtr->internalRep.longValue; + objPtr = Tcl_NewLongObj( + (opCode == INST_UMINUS)? -i : !i); + TRACE_WITH_OBJ(("%s %ld => ", opName[opCode], i), + objPtr); /* NB: stack top is off by 1 */ + } else { + d = valuePtr->internalRep.doubleValue; + if (opCode == INST_UMINUS) { + objPtr = Tcl_NewDoubleObj(-d); + } else { + /* + * Should be able to use "!d", but apparently + * some compilers can't handle it. + */ + objPtr = Tcl_NewLongObj((d==0.0)? 1 : 0); + } + TRACE_WITH_OBJ(("%s %.6g => ", opName[opCode], d), + objPtr); /* NB: stack top is off by 1 */ + } + PUSH_OBJECT(objPtr); + TclDecrRefCount(valuePtr); + } else { + /* + * valuePtr is unshared. Modify it directly. + */ + if (tPtr == &tclIntType) { + i = valuePtr->internalRep.longValue; + Tcl_SetLongObj(valuePtr, + (opCode == INST_UMINUS)? -i : !i); + TRACE_WITH_OBJ(("%s %ld => ", opName[opCode], i), + valuePtr); /* NB: stack top is off by 1 */ + } else { + d = valuePtr->internalRep.doubleValue; + if (opCode == INST_UMINUS) { + Tcl_SetDoubleObj(valuePtr, -d); + } else { + /* + * Should be able to use "!d", but apparently + * some compilers can't handle it. + */ + Tcl_SetLongObj(valuePtr, (d==0.0)? 1 : 0); + } + TRACE_WITH_OBJ(("%s %.6g => ", opName[opCode], d), + valuePtr); /* NB: stack top is off by 1 */ + } + ++stackTop; /* valuePtr now on stk top has right r.c. */ + } + } + ADJUST_PC(1); + + case INST_BITNOT: + { + /* + * The operand must be an integer. If the operand object is + * unshared modify it directly, otherwise modify a copy. + * Free any old string representation since it is now + * invalid. + */ + + Tcl_ObjType *tPtr; + + valuePtr = POP_OBJECT(); + tPtr = valuePtr->typePtr; + if (tPtr != &tclIntType) { + result = Tcl_GetLongFromObj((Tcl_Interp *) NULL, + valuePtr, &i); + if (result != TCL_OK) { /* try to convert to double */ + TRACE(("bitnot \"%.20s\" => ILLEGAL TYPE %s\n", + O2S(valuePtr), (tPtr? tPtr->name : "null"))); + IllegalExprOperandType(interp, opCode, valuePtr); + Tcl_DecrRefCount(valuePtr); + goto checkForCatch; + } + } + + i = valuePtr->internalRep.longValue; + if (Tcl_IsShared(valuePtr)) { + PUSH_OBJECT(Tcl_NewLongObj(~i)); + TRACE(("bitnot 0x%lx => (%lu)\n", i, ~i)); + TclDecrRefCount(valuePtr); + } else { + /* + * valuePtr is unshared. Modify it directly. + */ + Tcl_SetLongObj(valuePtr, ~i); + ++stackTop; /* valuePtr now on stk top has right r.c. */ + TRACE(("bitnot 0x%lx => (%lu)\n", i, ~i)); + } + } + ADJUST_PC(1); + + case INST_CALL_BUILTIN_FUNC1: + opnd = TclGetUInt1AtPtr(pc+1); + { + /* + * Call one of the built-in Tcl math functions. + */ + + BuiltinFunc *mathFuncPtr; + + if ((opnd < 0) || (opnd > LAST_BUILTIN_FUNC)) { + TRACE(("UNRECOGNIZED BUILTIN FUNC CODE %d\n", opnd)); + panic("TclExecuteByteCode: unrecognized builtin function code %d", opnd); + } + mathFuncPtr = &(builtinFuncTable[opnd]); + DECACHE_STACK_INFO(); + tcl_MathInProgress++; + result = (*mathFuncPtr->proc)(interp, eePtr, + mathFuncPtr->clientData); + tcl_MathInProgress--; + CACHE_STACK_INFO(); + if (result != TCL_OK) { + goto checkForCatch; + } + TRACE_WITH_OBJ(("callBuiltinFunc1 %d => ", opnd), + stackPtr[stackTop].o); + } + ADJUST_PC(2); + + case INST_CALL_FUNC1: + opnd = TclGetUInt1AtPtr(pc+1); + { + /* + * Call a non-builtin Tcl math function previously + * registered by a call to Tcl_CreateMathFunc. + */ + + int objc = opnd; /* Number of arguments. The function name + * is the 0-th argument. */ + Tcl_Obj **objv; /* The array of arguments. The function + * name is objv[0]. */ + + objv = &(stackPtr[stackTop - (objc-1)].o); /* "objv[0]" */ + DECACHE_STACK_INFO(); + tcl_MathInProgress++; + result = ExprCallMathFunc(interp, eePtr, objc, objv); + tcl_MathInProgress--; + CACHE_STACK_INFO(); + if (result != TCL_OK) { + goto checkForCatch; + } + TRACE_WITH_OBJ(("callFunc1 %d => ", objc), + stackPtr[stackTop].o); + ADJUST_PC(2); + } + + case INST_TRY_CVT_TO_NUMERIC: + { + /* + * Try to convert the topmost stack object to an int or + * double object. This is done in order to support Tcl's + * policy of interpreting operands if at all possible as + * first integers, else floating-point numbers. + */ + + double d; + char *s; + Tcl_ObjType *tPtr; + int converted, shared; + + valuePtr = stackPtr[stackTop].o; + tPtr = valuePtr->typePtr; + converted = 0; + if ((tPtr != &tclIntType) && (tPtr != &tclDoubleType)) { + s = Tcl_GetStringFromObj(valuePtr, (int *) NULL); + if (TclLooksLikeInt(s)) { /* FAILS IF NULLS */ + result = Tcl_GetLongFromObj((Tcl_Interp *) NULL, + valuePtr, &i); + } else { + result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL, + valuePtr, &d); + } + if (result == TCL_OK) { + converted = 1; + } + result = TCL_OK; /* reset the result variable */ + tPtr = valuePtr->typePtr; + } + + /* + * Ensure that the topmost stack object, if numeric, has a + * string rep the same as the formatted version of its + * internal rep. This is used, e.g., to make sure that "expr + * {0001}" yields "1", not "0001". We implement this by + * _discarding_ the string rep since we know it will be + * regenerated, if needed later, by formatting the internal + * rep's value. Also check if there has been an IEEE + * floating point error. + */ + + if ((tPtr == &tclIntType) || (tPtr == &tclDoubleType)) { + shared = 0; + if (Tcl_IsShared(valuePtr)) { + shared = 1; + if (tPtr == &tclIntType) { + i = valuePtr->internalRep.longValue; + objPtr = Tcl_NewLongObj(i); + } else { + d = valuePtr->internalRep.doubleValue; + objPtr = Tcl_NewDoubleObj(d); + } + Tcl_IncrRefCount(objPtr); + TclDecrRefCount(valuePtr); + valuePtr = objPtr; + tPtr = valuePtr->typePtr; + } else { + Tcl_InvalidateStringRep(valuePtr); + } + stackPtr[stackTop].o = valuePtr; + + if (tPtr == &tclDoubleType) { + d = valuePtr->internalRep.doubleValue; + if (IS_NAN(d) || IS_INF(d)) { + TRACE(("tryCvtToNumeric \"%.20s\" => IEEE FLOATING PT ERROR\n", + O2S(valuePtr))); + TclExprFloatError(interp, d); + result = TCL_ERROR; + goto checkForCatch; + } + } + shared = shared; /* lint, shared not used. */ + converted = converted; /* lint, converted not used. */ + TRACE(("tryCvtToNumeric \"%.20s\" => numeric, %s, %s\n", + O2S(valuePtr), + (converted? "converted" : "not converted"), + (shared? "shared" : "not shared"))); + } else { + TRACE(("tryCvtToNumeric \"%.20s\" => not numeric\n", + O2S(valuePtr))); + } + } + ADJUST_PC(1); + + case INST_BREAK: + /* + * First reset the interpreter's result. Then find the closest + * enclosing loop or catch exception range, if any. If a loop is + * found, terminate its execution. If the closest is a catch + * exception range, jump to its catchOffset. If no enclosing + * range is found, stop execution and return TCL_BREAK. + */ + + Tcl_ResetResult(interp); + rangePtr = TclGetExceptionRangeForPc(pc, /*catchOnly*/ 0, + codePtr); + if (rangePtr == NULL) { + TRACE(("break => no encl. loop or catch, returning TCL_BREAK\n")); + result = TCL_BREAK; + goto abnormalReturn; /* no catch exists to check */ + } + switch (rangePtr->type) { + case LOOP_EXCEPTION_RANGE: + result = TCL_OK; + TRACE(("break => range at %d, new pc %d\n", + rangePtr->codeOffset, rangePtr->breakOffset)); + break; + case CATCH_EXCEPTION_RANGE: + result = TCL_BREAK; + TRACE(("break => ...\n")); + goto processCatch; /* it will use rangePtr */ + default: + panic("TclExecuteByteCode: unrecognized ExceptionRange type %d\n", rangePtr->type); + } + pc = (codePtr->codeStart + rangePtr->breakOffset); + continue; /* restart outer instruction loop at pc */ + + case INST_CONTINUE: + /* + * Find the closest enclosing loop or catch exception range, + * if any. If a loop is found, skip to its next iteration. + * If the closest is a catch exception range, jump to its + * catchOffset. If no enclosing range is found, stop + * execution and return TCL_CONTINUE. + */ + + Tcl_ResetResult(interp); + rangePtr = TclGetExceptionRangeForPc(pc, /*catchOnly*/ 0, + codePtr); + if (rangePtr == NULL) { + TRACE(("continue => no encl. loop or catch, returning TCL_CONTINUE\n")); + result = TCL_CONTINUE; + goto abnormalReturn; + } + switch (rangePtr->type) { + case LOOP_EXCEPTION_RANGE: + if (rangePtr->continueOffset == -1) { + TRACE(("continue => loop w/o continue, checking for catch\n")); + goto checkForCatch; + } else { + result = TCL_OK; + TRACE(("continue => range at %d, new pc %d\n", + rangePtr->codeOffset, rangePtr->continueOffset)); + } + break; + case CATCH_EXCEPTION_RANGE: + result = TCL_CONTINUE; + TRACE(("continue => ...\n")); + goto processCatch; /* it will use rangePtr */ + default: + panic("TclExecuteByteCode: unrecognized ExceptionRange type %d\n", rangePtr->type); + } + pc = (codePtr->codeStart + rangePtr->continueOffset); + continue; /* restart outer instruction loop at pc */ + + case INST_FOREACH_START4: + opnd = TclGetUInt4AtPtr(pc+1); + { + /* + * Initialize the temporary local var that holds the count + * of the number of iterations of the loop body to -1. + */ + + ForeachInfo *infoPtr = (ForeachInfo *) + codePtr->auxDataArrayPtr[opnd].clientData; + int iterTmpIndex = infoPtr->loopIterNumTmp; + CallFrame *varFramePtr = iPtr->varFramePtr; + Var *compiledLocals = varFramePtr->compiledLocals; + Var *iterVarPtr; + Tcl_Obj *oldValuePtr; + + iterVarPtr = &(compiledLocals[iterTmpIndex]); + oldValuePtr = iterVarPtr->value.objPtr; + if (oldValuePtr == NULL) { + iterVarPtr->value.objPtr = Tcl_NewLongObj(-1); + Tcl_IncrRefCount(iterVarPtr->value.objPtr); + if (oldValuePtr != NULL) { + Tcl_DecrRefCount(oldValuePtr); + } + } else { + Tcl_SetLongObj(oldValuePtr, -1); + } + TclSetVarScalar(iterVarPtr); + TclClearVarUndefined(iterVarPtr); + TRACE(("foreach_start4 %u => loop iter count temp %d\n", + opnd, iterTmpIndex)); + } + ADJUST_PC(5); + + case INST_FOREACH_STEP4: + opnd = TclGetUInt4AtPtr(pc+1); + { + /* + * "Step" a foreach loop (i.e., begin its next iteration) by + * assigning the next value list element to each loop var. + */ + + ForeachInfo *infoPtr = (ForeachInfo *) + codePtr->auxDataArrayPtr[opnd].clientData; + ForeachVarList *varListPtr; + int numLists = infoPtr->numLists; + int iterTmpIndex = infoPtr->loopIterNumTmp; + CallFrame *varFramePtr = iPtr->varFramePtr; + Var *compiledLocals = varFramePtr->compiledLocals; + int iterNum, listTmpIndex, listLen, numVars; + int varIndex, valIndex, j; + Tcl_Obj *listPtr, *elemPtr, *oldValuePtr; + List *listRepPtr; + Var *iterVarPtr, *listVarPtr; + int continueLoop = 0; + + /* + * Increment the temp holding the loop iteration number. + */ + + iterVarPtr = &(compiledLocals[iterTmpIndex]); + oldValuePtr = iterVarPtr->value.objPtr; + iterNum = (oldValuePtr->internalRep.longValue + 1); + Tcl_SetLongObj(oldValuePtr, iterNum); + + /* + * Check whether all value lists are exhausted and we should + * stop the loop. + */ + + listTmpIndex = infoPtr->firstListTmp; + for (i = 0; i < numLists; i++) { + varListPtr = infoPtr->varLists[i]; + numVars = varListPtr->numVars; + + listVarPtr = &(compiledLocals[listTmpIndex]); + listPtr = listVarPtr->value.objPtr; + result = Tcl_ListObjLength(interp, listPtr, &listLen); + if (result != TCL_OK) { + TRACE_WITH_OBJ(("foreach_step4 %u => ERROR converting list %ld, \"%s\": ", + opnd, i, O2S(listPtr)), + Tcl_GetObjResult(interp)); + goto checkForCatch; + } + if (listLen > (iterNum * numVars)) { + continueLoop = 1; + } + listTmpIndex++; + } + + /* + * If some var in some var list still has a remaining list + * element iterate one more time. Assign to var the next + * element from its value list. We already checked above + * that each list temp holds a valid list object. + */ + + if (continueLoop) { + listTmpIndex = infoPtr->firstListTmp; + for (i = 0; i < numLists; i++) { + varListPtr = infoPtr->varLists[i]; + numVars = varListPtr->numVars; + + listVarPtr = &(compiledLocals[listTmpIndex]); + listPtr = listVarPtr->value.objPtr; + listRepPtr = (List *) + listPtr->internalRep.otherValuePtr; + listLen = listRepPtr->elemCount; + + valIndex = (iterNum * numVars); + for (j = 0; j < numVars; j++) { + int setEmptyStr = 0; + if (valIndex >= listLen) { + setEmptyStr = 1; + elemPtr = Tcl_NewObj(); + } else { + elemPtr = listRepPtr->elements[valIndex]; + } + + varIndex = varListPtr->varIndexes[j]; + DECACHE_STACK_INFO(); + value2Ptr = TclSetIndexedScalar(interp, + varIndex, elemPtr, /*leaveErrorMsg*/ 1); + CACHE_STACK_INFO(); + if (value2Ptr == NULL) { + TRACE_WITH_OBJ(("foreach_step4 %u => ERROR init. index temp %d: ", + opnd, varIndex), + Tcl_GetObjResult(interp)); + if (setEmptyStr) { + Tcl_DecrRefCount(elemPtr); /* unneeded */ + } + result = TCL_ERROR; + goto checkForCatch; + } + valIndex++; + } + listTmpIndex++; + } + } + + /* + * Now push a "1" object if at least one value list had a + * remaining element and the loop should continue. + * Otherwise push "0". + */ + + PUSH_OBJECT(Tcl_NewLongObj(continueLoop)); + TRACE(("foreach_step4 %u => %d lists, iter %d, %s loop\n", + opnd, numLists, iterNum, + (continueLoop? "continue" : "exit"))); + } + ADJUST_PC(5); + + case INST_BEGIN_CATCH4: + /* + * Record start of the catch command with exception range index + * equal to the operand. Push the current stack depth onto the + * special catch stack. + */ + catchStackPtr[++catchTop] = stackTop; + TRACE(("beginCatch4 %u => catchTop=%d, stackTop=%d\n", + TclGetUInt4AtPtr(pc+1), catchTop, stackTop)); + ADJUST_PC(5); + + case INST_END_CATCH: + catchTop--; + result = TCL_OK; + TRACE(("endCatch => catchTop=%d\n", catchTop)); + ADJUST_PC(1); + + case INST_PUSH_RESULT: + PUSH_OBJECT(Tcl_GetObjResult(interp)); + TRACE_WITH_OBJ(("pushResult => "), Tcl_GetObjResult(interp)); + ADJUST_PC(1); + + case INST_PUSH_RETURN_CODE: + PUSH_OBJECT(Tcl_NewLongObj(result)); + TRACE(("pushReturnCode => %u\n", result)); + ADJUST_PC(1); + + default: + TRACE(("UNRECOGNIZED INSTRUCTION %u\n", opCode)); + panic("TclExecuteByteCode: unrecognized opCode %u", opCode); + } /* end of switch on opCode */ + + /* + * Division by zero in an expression. Control only reaches this + * point by "goto divideByZero". + */ + + divideByZero: + Tcl_ResetResult(interp); + Tcl_AppendToObj(Tcl_GetObjResult(interp), "divide by zero", -1); + Tcl_SetErrorCode(interp, "ARITH", "DIVZERO", "divide by zero", + (char *) NULL); + result = TCL_ERROR; + + /* + * Execution has generated an "exception" such as TCL_ERROR. If the + * exception is an error, record information about what was being + * executed when the error occurred. Find the closest enclosing + * catch range, if any. If no enclosing catch range is found, stop + * execution and return the "exception" code. + */ + + checkForCatch: + if ((result == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) { + RecordTracebackInfo(interp, pc, codePtr); + } + rangePtr = TclGetExceptionRangeForPc(pc, /*catchOnly*/ 1, codePtr); + if (rangePtr == NULL) { + TRACE((" ... no enclosing catch, returning %s\n", + StringForResultCode(result))); + goto abnormalReturn; + } + + /* + * A catch exception range (rangePtr) was found to handle an + * "exception". It was found either by checkForCatch just above or + * by an instruction during break, continue, or error processing. + * Jump to its catchOffset after unwinding the operand stack to + * the depth it had when starting to execute the range's catch + * command. + */ + + processCatch: + while (stackTop > catchStackPtr[catchTop]) { + valuePtr = POP_OBJECT(); + TclDecrRefCount(valuePtr); + } + TRACE((" ... found catch at %d, catchTop=%d, unwound to %d, new pc %u\n", + rangePtr->codeOffset, catchTop, catchStackPtr[catchTop], + (unsigned int)(rangePtr->catchOffset))); + pc = (codePtr->codeStart + rangePtr->catchOffset); + continue; /* restart the execution loop at pc */ + } /* end of infinite loop dispatching on instructions */ + + /* + * Abnormal return code. Restore the stack to state it had when starting + * to execute the ByteCode. + */ + + abnormalReturn: + while (stackTop > initStackTop) { + valuePtr = POP_OBJECT(); + Tcl_DecrRefCount(valuePtr); + } + + /* + * Free the catch stack array if malloc'ed storage was used. + */ + + done: + if (catchStackPtr != catchStackStorage) { + ckfree((char *) catchStackPtr); + } + eePtr->stackTop = initStackTop; + return result; +#undef STATIC_CATCH_STACK_SIZE +} + +/* + *---------------------------------------------------------------------- + * + * PrintByteCodeInfo -- + * + * This procedure prints a summary about a bytecode object to stdout. + * It is called by TclExecuteByteCode when starting to execute the + * bytecode object if tclTraceExec has the value 2 or more. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static void +PrintByteCodeInfo(codePtr) + register ByteCode *codePtr; /* The bytecode whose summary is printed + * to stdout. */ +{ + Proc *procPtr = codePtr->procPtr; + int numCmds = codePtr->numCommands; + int numObjs = codePtr->numObjects; + int objBytes, i; + + objBytes = (numObjs * sizeof(Tcl_Obj)); + for (i = 0; i < numObjs; i++) { + Tcl_Obj *litObjPtr = codePtr->objArrayPtr[i]; + if (litObjPtr->bytes != NULL) { + objBytes += litObjPtr->length; + } + } + + fprintf(stdout, "\nExecuting ByteCode 0x%x, ref ct %u, epoch %u, interp 0x%x(epoch %u)\n", + (unsigned int) codePtr, codePtr->refCount, + codePtr->compileEpoch, (unsigned int) codePtr->iPtr, + codePtr->iPtr->compileEpoch); + + fprintf(stdout, " Source: "); + TclPrintSource(stdout, codePtr->source, 70); + + fprintf(stdout, "\n Cmds %d, chars %d, inst %u, objs %u, aux %d, stk depth %u, code/src %.2fn", + numCmds, codePtr->numSrcChars, codePtr->numCodeBytes, numObjs, + codePtr->numAuxDataItems, codePtr->maxStackDepth, + (codePtr->numSrcChars? + ((float)codePtr->totalSize)/((float)codePtr->numSrcChars) : 0.0)); + + fprintf(stdout, " Code %d = %d(header)+%d(inst)+%d(objs)+%d(exc)+%d(aux)+%d(cmd map)\n", + codePtr->totalSize, sizeof(ByteCode), codePtr->numCodeBytes, + objBytes, (codePtr->numExcRanges * sizeof(ExceptionRange)), + (codePtr->numAuxDataItems * sizeof(AuxData)), + codePtr->numCmdLocBytes); + + if (procPtr != NULL) { + fprintf(stdout, + " Proc 0x%x, ref ct %d, args %d, compiled locals %d\n", + (unsigned int) procPtr, procPtr->refCount, + procPtr->numArgs, procPtr->numCompiledLocals); + } +} + +/* + *---------------------------------------------------------------------- + * + * ValidatePcAndStackTop -- + * + * This procedure is called by TclExecuteByteCode when debugging to + * verify that the program counter and stack top are valid during + * execution. + * + * Results: + * None. + * + * Side effects: + * Prints a message to stderr and panics if either the pc or stack + * top are invalid. + * + *---------------------------------------------------------------------- + */ + +#ifdef TCL_COMPILE_DEBUG +static void +ValidatePcAndStackTop(codePtr, pc, stackTop, stackLowerBound, stackUpperBound) + register ByteCode *codePtr; /* The bytecode whose summary is printed + * to stdout. */ + unsigned char *pc; /* Points to first byte of a bytecode + * instruction. The program counter. */ + int stackTop; /* Current stack top. Must be between + * stackLowerBound and stackUpperBound + * (inclusive). */ + int stackLowerBound; /* Smallest legal value for stackTop. */ + int stackUpperBound; /* Greatest legal value for stackTop. */ +{ + unsigned int relativePc = (unsigned int) (pc - codePtr->codeStart); + unsigned int codeStart = (unsigned int) codePtr->codeStart; + unsigned int codeEnd = (unsigned int) + (codePtr->codeStart + codePtr->numCodeBytes); + unsigned char opCode = *pc; + + if (((unsigned int) pc < codeStart) || ((unsigned int) pc > codeEnd)) { + fprintf(stderr, "\nBad instruction pc 0x%x in TclExecuteByteCode\n", + (unsigned int) pc); + panic("TclExecuteByteCode execution failure: bad pc"); + } + if ((unsigned int) opCode > LAST_INST_OPCODE) { + fprintf(stderr, "\nBad opcode %d at pc %u in TclExecuteByteCode\n", + (unsigned int) opCode, relativePc); + panic("TclExecuteByteCode execution failure: bad opcode"); + } + if ((stackTop < stackLowerBound) || (stackTop > stackUpperBound)) { + int numChars; + char *cmd = GetSrcInfoForPc(pc, codePtr, &numChars); + char *ellipsis = ""; + + fprintf(stderr, "\nBad stack top %d at pc %u in TclExecuteByteCode", + stackTop, relativePc); + if (cmd != NULL) { + if (numChars > 100) { + numChars = 100; + ellipsis = "..."; + } + fprintf(stderr, "\n executing %.*s%s\n", numChars, cmd, + ellipsis); + } else { + fprintf(stderr, "\n"); + } + panic("TclExecuteByteCode execution failure: bad stack top"); + } +} +#endif /* TCL_COMPILE_DEBUG */ + +/* + *---------------------------------------------------------------------- + * + * IllegalExprOperandType -- + * + * Used by TclExecuteByteCode to add an error message to errorInfo + * when an illegal operand type is detected by an expression + * instruction. The argument opCode holds the failing instruction's + * opcode and opndPtr holds the operand object in error. + * + * Results: + * None. + * + * Side effects: + * An error message is appended to errorInfo. + * + *---------------------------------------------------------------------- + */ + +static void +IllegalExprOperandType(interp, opCode, opndPtr) + Tcl_Interp *interp; /* Interpreter to which error information + * pertains. */ + unsigned int opCode; /* The instruction opcode being executed + * when the illegal type was found. */ + Tcl_Obj *opndPtr; /* Points to the operand holding the value + * with the illegal type. */ +{ + Tcl_ResetResult(interp); + if ((opndPtr->bytes == NULL) || (opndPtr->length == 0)) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "can't use empty string as operand of \"", + operatorStrings[opCode - INST_LOR], "\"", (char *) NULL); + } else { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "can't use ", + ((opndPtr->typePtr == &tclDoubleType) ? + "floating-point value" : "non-numeric string"), + " as operand of \"", operatorStrings[opCode - INST_LOR], + "\"", (char *) NULL); + } +} + +/* + *---------------------------------------------------------------------- + * + * CallTraceProcedure -- + * + * Invokes a trace procedure registered with an interpreter. These + * procedures trace command execution. Currently this trace procedure + * is called with the address of the string-based Tcl_CmdProc for the + * command, not the Tcl_ObjCmdProc. + * + * Results: + * None. + * + * Side effects: + * Those side effects made by the trace procedure. + * + *---------------------------------------------------------------------- + */ + +static void +CallTraceProcedure(interp, tracePtr, cmdPtr, command, numChars, objc, objv) + Tcl_Interp *interp; /* The current interpreter. */ + register Trace *tracePtr; /* Describes the trace procedure to call. */ + Command *cmdPtr; /* Points to command's Command struct. */ + char *command; /* Points to the first character of the + * command's source before substitutions. */ + int numChars; /* The number of characters in the + * command's source. */ + register int objc; /* Number of arguments for the command. */ + Tcl_Obj *objv[]; /* Pointers to Tcl_Obj of each argument. */ +{ + Interp *iPtr = (Interp *) interp; + register char **argv; + register int i; + int length; + char *p; + + /* + * Get the string rep from the objv argument objects and place their + * pointers in argv. First make sure argv is large enough to hold the + * objc args plus 1 extra word for the zero end-of-argv word. + * THIS FAILS IF AN OBJECT'S STRING REP CONTAINS NULLS. + */ + + argv = (char **) ckalloc((unsigned)(objc + 1) * sizeof(char *)); + for (i = 0; i < objc; i++) { + argv[i] = Tcl_GetStringFromObj(objv[i], &length); + } + argv[objc] = 0; + + /* + * Copy the command characters into a new string. + */ + + p = (char *) ckalloc((unsigned) (numChars + 1)); + memcpy((VOID *) p, (VOID *) command, (size_t) numChars); + p[numChars] = '\0'; + + /* + * Call the trace procedure then free allocated storage. + */ + + (*tracePtr->proc)(tracePtr->clientData, interp, iPtr->numLevels, + p, cmdPtr->proc, cmdPtr->clientData, objc, argv); + + ckfree((char *) argv); + ckfree((char *) p); +} + +/* + *---------------------------------------------------------------------- + * + * RecordTracebackInfo -- + * + * Procedure called by TclExecuteByteCode to record information + * about what was being executed when the error occurred. + * + * Results: + * None. + * + * Side effects: + * Appends information about the command being executed to the + * "errorInfo" variable. Sets the errorLine field in the interpreter + * to the line number of that command. Sets the ERR_ALREADY_LOGGED + * bit in the interpreter's execution flags. + * + *---------------------------------------------------------------------- + */ + +static void +RecordTracebackInfo(interp, pc, codePtr) + Tcl_Interp *interp; /* The interpreter in which the error + * occurred. */ + unsigned char *pc; /* The program counter value where the error * occurred. This points to a bytecode + * instruction in codePtr's code. */ + ByteCode *codePtr; /* The bytecode sequence being executed. */ +{ + register Interp *iPtr = (Interp *) interp; + char *cmd, *ellipsis; + char buf[200]; + register char *p; + int numChars; + + /* + * Record the command in errorInfo (up to a certain number of + * characters, or up to the first newline). + */ + + iPtr->errorLine = 1; + cmd = GetSrcInfoForPc(pc, codePtr, &numChars); + if (cmd != NULL) { + for (p = codePtr->source; p != cmd; p++) { + if (*p == '\n') { + iPtr->errorLine++; + } + } + for ( ; (isspace(UCHAR(*p)) || (*p == ';')); p++) { + if (*p == '\n') { + iPtr->errorLine++; + } + } + + ellipsis = ""; + if (numChars > 150) { + numChars = 150; + ellipsis = "..."; + } + if (!(iPtr->flags & ERR_IN_PROGRESS)) { + sprintf(buf, "\n while executing\n\"%.*s%s\"", + numChars, cmd, ellipsis); + } else { + sprintf(buf, "\n invoked from within\n\"%.*s%s\"", + numChars, cmd, ellipsis); + } + Tcl_AddObjErrorInfo(interp, buf, -1); + iPtr->flags |= ERR_ALREADY_LOGGED; + } +} + +/* + *---------------------------------------------------------------------- + * + * GetSrcInfoForPc -- + * + * Given a program counter value, finds the closest command in the + * bytecode code unit's CmdLocation array and returns information about + * that command's source: a pointer to its first byte and the number of + * characters. + * + * Results: + * If a command is found that encloses the program counter value, a + * pointer to the command's source is returned and the length of the + * source is stored at *lengthPtr. If multiple commands resulted in + * code at pc, information about the closest enclosing command is + * returned. If no matching command is found, NULL is returned and + * *lengthPtr is unchanged. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static char * +GetSrcInfoForPc(pc, codePtr, lengthPtr) + unsigned char *pc; /* The program counter value for which to + * return the closest command's source info. + * This points to a bytecode instruction + * in codePtr's code. */ + ByteCode *codePtr; /* The bytecode sequence in which to look + * up the command source for the pc. */ + int *lengthPtr; /* If non-NULL, the location where the + * length of the command's source should be + * stored. If NULL, no length is stored. */ +{ + register int pcOffset = (pc - codePtr->codeStart); + int numCmds = codePtr->numCommands; + unsigned char *codeDeltaNext, *codeLengthNext; + unsigned char *srcDeltaNext, *srcLengthNext; + int codeOffset, codeLen, codeEnd, srcOffset, srcLen, delta, i; + int bestDist = INT_MAX; /* Distance of pc to best cmd's start pc. */ + int bestSrcOffset = -1; /* Initialized to avoid compiler warning. */ + int bestSrcLength = -1; /* Initialized to avoid compiler warning. */ + + if ((pcOffset < 0) || (pcOffset >= codePtr->numCodeBytes)) { + return NULL; + } + + /* + * Decode the code and source offset and length for each command. The + * closest enclosing command is the last one whose code started before + * pcOffset. + */ + + codeDeltaNext = codePtr->codeDeltaStart; + codeLengthNext = codePtr->codeLengthStart; + srcDeltaNext = codePtr->srcDeltaStart; + srcLengthNext = codePtr->srcLengthStart; + codeOffset = srcOffset = 0; + for (i = 0; i < numCmds; i++) { + if ((unsigned int) (*codeDeltaNext) == (unsigned int) 0xFF) { + codeDeltaNext++; + delta = TclGetInt4AtPtr(codeDeltaNext); + codeDeltaNext += 4; + } else { + delta = TclGetInt1AtPtr(codeDeltaNext); + codeDeltaNext++; + } + codeOffset += delta; + + if ((unsigned int) (*codeLengthNext) == (unsigned int) 0xFF) { + codeLengthNext++; + codeLen = TclGetInt4AtPtr(codeLengthNext); + codeLengthNext += 4; + } else { + codeLen = TclGetInt1AtPtr(codeLengthNext); + codeLengthNext++; + } + codeEnd = (codeOffset + codeLen - 1); + + if ((unsigned int) (*srcDeltaNext) == (unsigned int) 0xFF) { + srcDeltaNext++; + delta = TclGetInt4AtPtr(srcDeltaNext); + srcDeltaNext += 4; + } else { + delta = TclGetInt1AtPtr(srcDeltaNext); + srcDeltaNext++; + } + srcOffset += delta; + + if ((unsigned int) (*srcLengthNext) == (unsigned int) 0xFF) { + srcLengthNext++; + srcLen = TclGetInt4AtPtr(srcLengthNext); + srcLengthNext += 4; + } else { + srcLen = TclGetInt1AtPtr(srcLengthNext); + srcLengthNext++; + } + + if (codeOffset > pcOffset) { /* best cmd already found */ + break; + } else if (pcOffset <= codeEnd) { /* this cmd's code encloses pc */ + int dist = (pcOffset - codeOffset); + if (dist <= bestDist) { + bestDist = dist; + bestSrcOffset = srcOffset; + bestSrcLength = srcLen; + } + } + } + + if (bestDist == INT_MAX) { + return NULL; + } + + if (lengthPtr != NULL) { + *lengthPtr = bestSrcLength; + } + return (codePtr->source + bestSrcOffset); +} + +/* + *---------------------------------------------------------------------- + * + * TclGetExceptionRangeForPc -- + * + * Procedure that given a program counter value, returns the closest + * enclosing ExceptionRange that matches the kind requested. + * + * Results: + * In the normal case, catchOnly is 0 (false) and this procedure + * returns a pointer to the most closely enclosing ExceptionRange + * structure regardless of whether it is a loop or catch exception + * range. This is appropriate when processing a TCL_BREAK or + * TCL_CONTINUE, which will be "handled" either by a loop exception + * range or a closer catch range. If catchOnly is nonzero (true), this + * procedure ignores loop exception ranges and returns a pointer to the + * closest catch range. If no matching ExceptionRange is found that + * encloses pc, a NULL is returned. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +ExceptionRange * +TclGetExceptionRangeForPc(pc, catchOnly, codePtr) + unsigned char *pc; /* The program counter value for which to + * search for a closest enclosing exception + * range. This points to a bytecode + * instruction in codePtr's code. */ + int catchOnly; /* If 0, consider either loop or catch + * ExceptionRanges in search. Otherwise + * consider only catch ranges (and ignore + * any closer loop ranges). */ + ByteCode* codePtr; /* Points to the ByteCode in which to search + * for the enclosing ExceptionRange. */ +{ + ExceptionRange *rangeArrayPtr = codePtr->excRangeArrayPtr; + int numRanges = codePtr->numExcRanges; + register ExceptionRange *rangePtr; + int codeOffset = (pc - codePtr->codeStart); + register int i, level; + + for (level = codePtr->maxExcRangeDepth; level >= 0; level--) { + for (i = 0; i < numRanges; i++) { + rangePtr = &(rangeArrayPtr[i]); + if (rangePtr->nestingLevel == level) { + int start = rangePtr->codeOffset; + int end = (start + rangePtr->numCodeBytes); + if ((start <= codeOffset) && (codeOffset < end)) { + if ((!catchOnly) + || (rangePtr->type == CATCH_EXCEPTION_RANGE)) { + return rangePtr; + } + } + } + } + } + return NULL; +} + +/* + *---------------------------------------------------------------------- + * + * Math Functions -- + * + * This page contains the procedures that implement all of the + * built-in math functions for expressions. + * + * Results: + * Each procedure returns TCL_OK if it succeeds and pushes an + * Tcl object holding the result. If it fails it returns TCL_ERROR + * and leaves an error message in the interpreter's result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +ExprUnaryFunc(interp, eePtr, clientData) + Tcl_Interp *interp; /* The interpreter in which to execute the + * function. */ + ExecEnv *eePtr; /* Points to the environment for executing + * the function. */ + ClientData clientData; /* Contains the address of a procedure that + * takes one double argument and returns a + * double result. */ +{ + StackItem *stackPtr; /* Cached evaluation stack base pointer. */ + register int stackTop; /* Cached top index of evaluation stack. */ + register Tcl_Obj *valuePtr; + Tcl_ObjType *tPtr; + double d, dResult; + long i; + int result = TCL_OK; + + double (*func) _ANSI_ARGS_((double)) = + (double (*)_ANSI_ARGS_((double))) clientData; + + /* + * Set stackPtr and stackTop from eePtr. + */ + + CACHE_STACK_INFO(); + + /* + * Pop the function's argument from the evaluation stack. Convert it + * to a double if necessary. + */ + + valuePtr = POP_OBJECT(); + tPtr = valuePtr->typePtr; + + if (tPtr == &tclIntType) { + d = (double) valuePtr->internalRep.longValue; + } else if (tPtr == &tclDoubleType) { + d = valuePtr->internalRep.doubleValue; + } else { /* FAILS IF STRING REP HAS NULLS */ + char *s = Tcl_GetStringFromObj(valuePtr, (int *) NULL); + + if (TclLooksLikeInt(s)) { + result = Tcl_GetLongFromObj((Tcl_Interp *) NULL, valuePtr, &i); + d = (double) valuePtr->internalRep.longValue; + } else { + result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL, valuePtr, &d); + } + if (result != TCL_OK) { + Tcl_ResetResult(interp); + Tcl_AppendToObj(Tcl_GetObjResult(interp), + "argument to math function didn't have numeric value", -1); + goto done; + } + } + + errno = 0; + dResult = (*func)(d); + if ((errno != 0) || IS_NAN(dResult) || IS_INF(dResult)) { + TclExprFloatError(interp, dResult); + result = TCL_ERROR; + goto done; + } + + /* + * Push a Tcl object holding the result. + */ + + PUSH_OBJECT(Tcl_NewDoubleObj(dResult)); + + /* + * Reflect the change to stackTop back in eePtr. + */ + + done: + Tcl_DecrRefCount(valuePtr); + DECACHE_STACK_INFO(); + return result; +} + +static int +ExprBinaryFunc(interp, eePtr, clientData) + Tcl_Interp *interp; /* The interpreter in which to execute the + * function. */ + ExecEnv *eePtr; /* Points to the environment for executing + * the function. */ + ClientData clientData; /* Contains the address of a procedure that + * takes two double arguments and + * returns a double result. */ +{ + StackItem *stackPtr; /* Cached evaluation stack base pointer. */ + register int stackTop; /* Cached top index of evaluation stack. */ + register Tcl_Obj *valuePtr, *value2Ptr; + Tcl_ObjType *tPtr; + double d1, d2, dResult; + long i; + char *s; + int result = TCL_OK; + + double (*func) _ANSI_ARGS_((double, double)) + = (double (*)_ANSI_ARGS_((double, double))) clientData; + + /* + * Set stackPtr and stackTop from eePtr. + */ + + CACHE_STACK_INFO(); + + /* + * Pop the function's two arguments from the evaluation stack. Convert + * them to doubles if necessary. + */ + + value2Ptr = POP_OBJECT(); + valuePtr = POP_OBJECT(); + + tPtr = valuePtr->typePtr; + if (tPtr == &tclIntType) { + d1 = (double) valuePtr->internalRep.longValue; + } else if (tPtr == &tclDoubleType) { + d1 = valuePtr->internalRep.doubleValue; + } else { /* FAILS IF STRING REP HAS NULLS */ + s = Tcl_GetStringFromObj(valuePtr, (int *) NULL); + if (TclLooksLikeInt(s)) { + result = Tcl_GetLongFromObj((Tcl_Interp *) NULL, valuePtr, &i); + d1 = (double) valuePtr->internalRep.longValue; + } else { + result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL, valuePtr, &d1); + } + if (result != TCL_OK) { + badArg: + Tcl_ResetResult(interp); + Tcl_AppendToObj(Tcl_GetObjResult(interp), + "argument to math function didn't have numeric value", -1); + goto done; + } + } + + tPtr = value2Ptr->typePtr; + if (tPtr == &tclIntType) { + d2 = value2Ptr->internalRep.longValue; + } else if (tPtr == &tclDoubleType) { + d2 = value2Ptr->internalRep.doubleValue; + } else { /* FAILS IF STRING REP HAS NULLS */ + s = Tcl_GetStringFromObj(value2Ptr, (int *) NULL); + if (TclLooksLikeInt(s)) { + result = Tcl_GetLongFromObj((Tcl_Interp *) NULL, value2Ptr, &i); + d2 = (double) value2Ptr->internalRep.longValue; + } else { + result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL, value2Ptr, &d2); + } + if (result != TCL_OK) { + goto badArg; + } + } + + errno = 0; + dResult = (*func)(d1, d2); + if ((errno != 0) || IS_NAN(dResult) || IS_INF(dResult)) { + TclExprFloatError(interp, dResult); + result = TCL_ERROR; + goto done; + } + + /* + * Push a Tcl object holding the result. + */ + + PUSH_OBJECT(Tcl_NewDoubleObj(dResult)); + + /* + * Reflect the change to stackTop back in eePtr. + */ + + done: + Tcl_DecrRefCount(valuePtr); + Tcl_DecrRefCount(value2Ptr); + DECACHE_STACK_INFO(); + return result; +} + +static int +ExprAbsFunc(interp, eePtr, clientData) + Tcl_Interp *interp; /* The interpreter in which to execute the + * function. */ + ExecEnv *eePtr; /* Points to the environment for executing + * the function. */ + ClientData clientData; /* Ignored. */ +{ + StackItem *stackPtr; /* Cached evaluation stack base pointer. */ + register int stackTop; /* Cached top index of evaluation stack. */ + register Tcl_Obj *valuePtr; + Tcl_ObjType *tPtr; + long i, iResult; + double d, dResult; + int result = TCL_OK; + + /* + * Set stackPtr and stackTop from eePtr. + */ + + CACHE_STACK_INFO(); + + /* + * Pop the argument from the evaluation stack. + */ + + valuePtr = POP_OBJECT(); + tPtr = valuePtr->typePtr; + + if (tPtr == &tclIntType) { + i = valuePtr->internalRep.longValue; + } else if (tPtr == &tclDoubleType) { + d = valuePtr->internalRep.doubleValue; + } else { /* FAILS IF STRING REP HAS NULLS */ + char *s = Tcl_GetStringFromObj(valuePtr, (int *) NULL); + + if (TclLooksLikeInt(s)) { + result = Tcl_GetLongFromObj((Tcl_Interp *) NULL, valuePtr, &i); + } else { + result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL, valuePtr, &d); + } + if (result != TCL_OK) { + Tcl_ResetResult(interp); + Tcl_AppendToObj(Tcl_GetObjResult(interp), + "argument to math function didn't have numeric value", -1); + goto done; + } + tPtr = valuePtr->typePtr; + } + + /* + * Push a Tcl object with the result. + */ + + if (tPtr == &tclIntType) { + if (i < 0) { + iResult = -i; + if (iResult < 0) { + Tcl_ResetResult(interp); + Tcl_AppendToObj(Tcl_GetObjResult(interp), + "integer value too large to represent", -1); + Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", + "integer value too large to represent", (char *) NULL); + result = TCL_ERROR; + goto done; + } + } else { + iResult = i; + } + PUSH_OBJECT(Tcl_NewLongObj(iResult)); + } else { + if (d < 0.0) { + dResult = -d; + } else { + dResult = d; + } + if (IS_NAN(dResult) || IS_INF(dResult)) { + TclExprFloatError(interp, dResult); + result = TCL_ERROR; + goto done; + } + PUSH_OBJECT(Tcl_NewDoubleObj(dResult)); + } + + /* + * Reflect the change to stackTop back in eePtr. + */ + + done: + Tcl_DecrRefCount(valuePtr); + DECACHE_STACK_INFO(); + return result; +} + +static int +ExprDoubleFunc(interp, eePtr, clientData) + Tcl_Interp *interp; /* The interpreter in which to execute the + * function. */ + ExecEnv *eePtr; /* Points to the environment for executing + * the function. */ + ClientData clientData; /* Ignored. */ +{ + StackItem *stackPtr; /* Cached evaluation stack base pointer. */ + register int stackTop; /* Cached top index of evaluation stack. */ + register Tcl_Obj *valuePtr; + double dResult; + long i; + int result = TCL_OK; + + /* + * Set stackPtr and stackTop from eePtr. + */ + + CACHE_STACK_INFO(); + + /* + * Pop the argument from the evaluation stack. + */ + + valuePtr = POP_OBJECT(); + if (valuePtr->typePtr == &tclIntType) { + dResult = (double) valuePtr->internalRep.longValue; + } else if (valuePtr->typePtr == &tclDoubleType) { + dResult = valuePtr->internalRep.doubleValue; + } else { /* FAILS IF STRING REP HAS NULLS */ + char *s = Tcl_GetStringFromObj(valuePtr, (int *) NULL); + + if (TclLooksLikeInt(s)) { + result = Tcl_GetLongFromObj((Tcl_Interp *) NULL, valuePtr, &i); + dResult = (double) valuePtr->internalRep.longValue; + } else { + result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL, valuePtr, + &dResult); + } + if (result != TCL_OK) { + Tcl_ResetResult(interp); + Tcl_AppendToObj(Tcl_GetObjResult(interp), + "argument to math function didn't have numeric value", -1); + goto done; + } + } + + /* + * Push a Tcl object with the result. + */ + + PUSH_OBJECT(Tcl_NewDoubleObj(dResult)); + + /* + * Reflect the change to stackTop back in eePtr. + */ + + done: + Tcl_DecrRefCount(valuePtr); + DECACHE_STACK_INFO(); + return result; +} + +static int +ExprIntFunc(interp, eePtr, clientData) + Tcl_Interp *interp; /* The interpreter in which to execute the + * function. */ + ExecEnv *eePtr; /* Points to the environment for executing + * the function. */ + ClientData clientData; /* Ignored. */ +{ + StackItem *stackPtr; /* Cached evaluation stack base pointer. */ + register int stackTop; /* Cached top index of evaluation stack. */ + register Tcl_Obj *valuePtr; + Tcl_ObjType *tPtr; + long i = 0; /* Initialized to avoid compiler warning. */ + long iResult; + double d; + int result = TCL_OK; + + /* + * Set stackPtr and stackTop from eePtr. + */ + + CACHE_STACK_INFO(); + + /* + * Pop the argument from the evaluation stack. + */ + + valuePtr = POP_OBJECT(); + tPtr = valuePtr->typePtr; + + if (tPtr == &tclIntType) { + i = valuePtr->internalRep.longValue; + } else if (tPtr == &tclDoubleType) { + d = valuePtr->internalRep.doubleValue; + } else { /* FAILS IF STRING REP HAS NULLS */ + char *s = Tcl_GetStringFromObj(valuePtr, (int *) NULL); + + if (TclLooksLikeInt(s)) { + result = Tcl_GetLongFromObj((Tcl_Interp *) NULL, valuePtr, &i); + } else { + result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL, valuePtr, &d); + } + if (result != TCL_OK) { + Tcl_ResetResult(interp); + Tcl_AppendToObj(Tcl_GetObjResult(interp), + "argument to math function didn't have numeric value", -1); + goto done; + } + tPtr = valuePtr->typePtr; + } + + /* + * Push a Tcl object with the result. + */ + + if (tPtr == &tclIntType) { + iResult = i; + } else { + if (d < 0.0) { + if (d < (double) (long) LONG_MIN) { + tooLarge: + Tcl_ResetResult(interp); + Tcl_AppendToObj(Tcl_GetObjResult(interp), + "integer value too large to represent", -1); + Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", + "integer value too large to represent", (char *) NULL); + result = TCL_ERROR; + goto done; + } + } else { + if (d > (double) LONG_MAX) { + goto tooLarge; + } + } + if (IS_NAN(d) || IS_INF(d)) { + TclExprFloatError(interp, d); + result = TCL_ERROR; + goto done; + } + iResult = (long) d; + } + PUSH_OBJECT(Tcl_NewLongObj(iResult)); + + /* + * Reflect the change to stackTop back in eePtr. + */ + + done: + Tcl_DecrRefCount(valuePtr); + DECACHE_STACK_INFO(); + return result; +} + +static int +ExprRandFunc(interp, eePtr, clientData) + Tcl_Interp *interp; /* The interpreter in which to execute the + * function. */ + ExecEnv *eePtr; /* Points to the environment for executing + * the function. */ + ClientData clientData; /* Ignored. */ +{ + StackItem *stackPtr; /* Cached evaluation stack base pointer. */ + register int stackTop; /* Cached top index of evaluation stack. */ + Interp *iPtr = (Interp *) interp; + double dResult; + int tmp; + + if (!(iPtr->flags & RAND_SEED_INITIALIZED)) { + iPtr->flags |= RAND_SEED_INITIALIZED; + iPtr->randSeed = TclpGetClicks(); + } + + /* + * Set stackPtr and stackTop from eePtr. + */ + + CACHE_STACK_INFO(); + + /* + * Generate the random number using the linear congruential + * generator defined by the following recurrence: + * seed = ( IA * seed ) mod IM + * where IA is 16807 and IM is (2^31) - 1. In order to avoid + * potential problems with integer overflow, the code uses + * additional constants IQ and IR such that + * IM = IA*IQ + IR + * For details on how this algorithm works, refer to the following + * papers: + * + * S.K. Park & K.W. Miller, "Random number generators: good ones + * are hard to find," Comm ACM 31(10):1192-1201, Oct 1988 + * + * W.H. Press & S.A. Teukolsky, "Portable random number + * generators," Computers in Physics 6(5):522-524, Sep/Oct 1992. + */ + +#define RAND_IA 16807 +#define RAND_IM 2147483647 +#define RAND_IQ 127773 +#define RAND_IR 2836 +#define RAND_MASK 123459876 + + if (iPtr->randSeed == 0) { + /* + * Don't allow a 0 seed, since it breaks the generator. Shift + * it to some other value. + */ + + iPtr->randSeed = 123459876; + } + tmp = iPtr->randSeed/RAND_IQ; + iPtr->randSeed = RAND_IA*(iPtr->randSeed - tmp*RAND_IQ) - RAND_IR*tmp; + if (iPtr->randSeed < 0) { + iPtr->randSeed += RAND_IM; + } + + /* + * On 64-bit architectures we need to mask off the upper bits to + * ensure we only have a 32-bit range. The constant has the + * bizarre form below in order to make sure that it doesn't + * get sign-extended (the rules for sign extension are very + * concat, particularly on 64-bit machines). + */ + + iPtr->randSeed &= ((((unsigned long) 0xfffffff) << 4) | 0xf); + dResult = iPtr->randSeed * (1.0/RAND_IM); + + /* + * Push a Tcl object with the result. + */ + + PUSH_OBJECT(Tcl_NewDoubleObj(dResult)); + + /* + * Reflect the change to stackTop back in eePtr. + */ + + DECACHE_STACK_INFO(); + return TCL_OK; +} + +static int +ExprRoundFunc(interp, eePtr, clientData) + Tcl_Interp *interp; /* The interpreter in which to execute the + * function. */ + ExecEnv *eePtr; /* Points to the environment for executing + * the function. */ + ClientData clientData; /* Ignored. */ +{ + StackItem *stackPtr; /* Cached evaluation stack base pointer. */ + register int stackTop; /* Cached top index of evaluation stack. */ + Tcl_Obj *valuePtr; + Tcl_ObjType *tPtr; + long i = 0; /* Initialized to avoid compiler warning. */ + long iResult; + double d, temp; + int result = TCL_OK; + + /* + * Set stackPtr and stackTop from eePtr. + */ + + CACHE_STACK_INFO(); + + /* + * Pop the argument from the evaluation stack. + */ + + valuePtr = POP_OBJECT(); + tPtr = valuePtr->typePtr; + + if (tPtr == &tclIntType) { + i = valuePtr->internalRep.longValue; + } else if (tPtr == &tclDoubleType) { + d = valuePtr->internalRep.doubleValue; + } else { /* FAILS IF STRING REP HAS NULLS */ + char *s = Tcl_GetStringFromObj(valuePtr, (int *) NULL); + + if (TclLooksLikeInt(s)) { + result = Tcl_GetLongFromObj((Tcl_Interp *) NULL, valuePtr, &i); + } else { + result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL, valuePtr, &d); + } + if (result != TCL_OK) { + Tcl_ResetResult(interp); + Tcl_AppendToObj(Tcl_GetObjResult(interp), + "argument to math function didn't have numeric value", -1); + goto done; + } + tPtr = valuePtr->typePtr; + } + + /* + * Push a Tcl object with the result. + */ + + if (tPtr == &tclIntType) { + iResult = i; + } else { + if (d < 0.0) { + if (d <= (((double) (long) LONG_MIN) - 0.5)) { + tooLarge: + Tcl_ResetResult(interp); + Tcl_AppendToObj(Tcl_GetObjResult(interp), + "integer value too large to represent", -1); + Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", + "integer value too large to represent", + (char *) NULL); + result = TCL_ERROR; + goto done; + } + temp = (long) (d - 0.5); + } else { + if (d >= (((double) LONG_MAX + 0.5))) { + goto tooLarge; + } + temp = (long) (d + 0.5); + } + if (IS_NAN(temp) || IS_INF(temp)) { + TclExprFloatError(interp, temp); + result = TCL_ERROR; + goto done; + } + iResult = (long) temp; + } + PUSH_OBJECT(Tcl_NewLongObj(iResult)); + + /* + * Reflect the change to stackTop back in eePtr. + */ + + done: + Tcl_DecrRefCount(valuePtr); + DECACHE_STACK_INFO(); + return result; +} + +static int +ExprSrandFunc(interp, eePtr, clientData) + Tcl_Interp *interp; /* The interpreter in which to execute the + * function. */ + ExecEnv *eePtr; /* Points to the environment for executing + * the function. */ + ClientData clientData; /* Ignored. */ +{ + StackItem *stackPtr; /* Cached evaluation stack base pointer. */ + register int stackTop; /* Cached top index of evaluation stack. */ + Interp *iPtr = (Interp *) interp; + Tcl_Obj *valuePtr; + Tcl_ObjType *tPtr; + long i = 0; /* Initialized to avoid compiler warning. */ + int result; + + /* + * Set stackPtr and stackTop from eePtr. + */ + + CACHE_STACK_INFO(); + + /* + * Pop the argument from the evaluation stack. Use the value + * to reset the random number seed. + */ + + valuePtr = POP_OBJECT(); + tPtr = valuePtr->typePtr; + + if (tPtr == &tclIntType) { + i = valuePtr->internalRep.longValue; + } else { /* FAILS IF STRING REP HAS NULLS */ + result = Tcl_GetLongFromObj((Tcl_Interp *) NULL, valuePtr, &i); + if (result != TCL_OK) { + Tcl_ResetResult(interp); + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "can't use ", + ((tPtr == &tclDoubleType)? "floating-point value" : "non-numeric string"), + " as argument to srand", (char *) NULL); + Tcl_DecrRefCount(valuePtr); + DECACHE_STACK_INFO(); + return result; + } + } + + /* + * Reset the seed. + */ + + iPtr->flags |= RAND_SEED_INITIALIZED; + iPtr->randSeed = i; + + /* + * To avoid duplicating the random number generation code we simply + * clean up our state and call the real random number function. That + * function will always succeed. + */ + + Tcl_DecrRefCount(valuePtr); + DECACHE_STACK_INFO(); + + ExprRandFunc(interp, eePtr, clientData); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * ExprCallMathFunc -- + * + * This procedure is invoked to call a non-builtin math function + * during the execution of an expression. + * + * Results: + * TCL_OK is returned if all went well and the function's value + * was computed successfully. If an error occurred, TCL_ERROR + * is returned and an error message is left in the interpreter's + * result. After a successful return this procedure pushes a Tcl object + * holding the result. + * + * Side effects: + * None, unless the called math function has side effects. + * + *---------------------------------------------------------------------- + */ + +static int +ExprCallMathFunc(interp, eePtr, objc, objv) + Tcl_Interp *interp; /* The interpreter in which to execute the + * function. */ + ExecEnv *eePtr; /* Points to the environment for executing + * the function. */ + int objc; /* Number of arguments. The function name is + * the 0-th argument. */ + Tcl_Obj **objv; /* The array of arguments. The function name + * is objv[0]. */ +{ + Interp *iPtr = (Interp *) interp; + StackItem *stackPtr; /* Cached evaluation stack base pointer. */ + register int stackTop; /* Cached top index of evaluation stack. */ + char *funcName; + Tcl_HashEntry *hPtr; + MathFunc *mathFuncPtr; /* Information about math function. */ + Tcl_Value args[MAX_MATH_ARGS]; /* Arguments for function call. */ + Tcl_Value funcResult; /* Result of function call as Tcl_Value. */ + register Tcl_Obj *valuePtr; + Tcl_ObjType *tPtr; + long i; + double d; + int j, k, result; + + Tcl_ResetResult(interp); + + /* + * Set stackPtr and stackTop from eePtr. + */ + + CACHE_STACK_INFO(); + + /* + * Look up the MathFunc record for the function. + * THIS FAILS IF THE OBJECT'S STRING REP CONTAINS NULLS. + */ + + funcName = Tcl_GetStringFromObj(objv[0], (int *) NULL); + hPtr = Tcl_FindHashEntry(&iPtr->mathFuncTable, funcName); + if (hPtr == NULL) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "unknown math function \"", funcName, "\"", (char *) NULL); + result = TCL_ERROR; + goto done; + } + mathFuncPtr = (MathFunc *) Tcl_GetHashValue(hPtr); + if (mathFuncPtr->numArgs != (objc-1)) { + panic("ExprCallMathFunc: expected number of args %d != actual number %d", + mathFuncPtr->numArgs, objc); + result = TCL_ERROR; + goto done; + } + + /* + * Collect the arguments for the function, if there are any, into the + * array "args". Note that args[0] will have the Tcl_Value that + * corresponds to objv[1]. + */ + + for (j = 1, k = 0; j < objc; j++, k++) { + valuePtr = objv[j]; + tPtr = valuePtr->typePtr; + + if (tPtr == &tclIntType) { + i = valuePtr->internalRep.longValue; + } else if (tPtr == &tclDoubleType) { + d = valuePtr->internalRep.doubleValue; + } else { + /* + * Try to convert to int first then double. + * FAILS IF STRING REP HAS NULLS. + */ + + char *s = Tcl_GetStringFromObj(valuePtr, (int *) NULL); + + if (TclLooksLikeInt(s)) { + result = Tcl_GetLongFromObj((Tcl_Interp *) NULL, valuePtr, &i); + } else { + result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL, + valuePtr, &d); + } + if (result != TCL_OK) { + Tcl_AppendToObj(Tcl_GetObjResult(interp), + "argument to math function didn't have numeric value", -1); + goto done; + } + tPtr = valuePtr->typePtr; + } + + /* + * Copy the object's numeric value to the argument record, + * converting it if necessary. + */ + + if (tPtr == &tclIntType) { + if (mathFuncPtr->argTypes[k] == TCL_DOUBLE) { + args[k].type = TCL_DOUBLE; + args[k].doubleValue = i; + } else { + args[k].type = TCL_INT; + args[k].intValue = i; + } + } else { + if (mathFuncPtr->argTypes[k] == TCL_INT) { + args[k].type = TCL_INT; + args[k].intValue = (long) d; + } else { + args[k].type = TCL_DOUBLE; + args[k].doubleValue = d; + } + } + } + + /* + * Invoke the function and copy its result back into valuePtr. + */ + + tcl_MathInProgress++; + result = (*mathFuncPtr->proc)(mathFuncPtr->clientData, interp, args, + &funcResult); + tcl_MathInProgress--; + if (result != TCL_OK) { + goto done; + } + + /* + * Pop the objc top stack elements and decrement their ref counts. + */ + + i = (stackTop - (objc-1)); + while (i <= stackTop) { + valuePtr = stackPtr[i].o; + Tcl_DecrRefCount(valuePtr); + i++; + } + stackTop -= objc; + + /* + * Push the call's object result. + */ + + if (funcResult.type == TCL_INT) { + PUSH_OBJECT(Tcl_NewLongObj(funcResult.intValue)); + } else { + d = funcResult.doubleValue; + if (IS_NAN(d) || IS_INF(d)) { + TclExprFloatError(interp, d); + result = TCL_ERROR; + goto done; + } + PUSH_OBJECT(Tcl_NewDoubleObj(d)); + } + + /* + * Reflect the change to stackTop back in eePtr. + */ + + done: + DECACHE_STACK_INFO(); + return result; +} + +/* + *---------------------------------------------------------------------- + * + * TclExprFloatError -- + * + * This procedure is called when an error occurs during a + * floating-point operation. It reads errno and sets + * interp->objResultPtr accordingly. + * + * Results: + * interp->objResultPtr is set to hold an error message. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +void +TclExprFloatError(interp, value) + Tcl_Interp *interp; /* Where to store error message. */ + double value; /* Value returned after error; used to + * distinguish underflows from overflows. */ +{ + char *s; + + Tcl_ResetResult(interp); + if ((errno == EDOM) || (value != value)) { + s = "domain error: argument not in valid range"; + Tcl_AppendToObj(Tcl_GetObjResult(interp), s, -1); + Tcl_SetErrorCode(interp, "ARITH", "DOMAIN", s, (char *) NULL); + } else if ((errno == ERANGE) || IS_INF(value)) { + if (value == 0.0) { + s = "floating-point value too small to represent"; + Tcl_AppendToObj(Tcl_GetObjResult(interp), s, -1); + Tcl_SetErrorCode(interp, "ARITH", "UNDERFLOW", s, (char *) NULL); + } else { + s = "floating-point value too large to represent"; + Tcl_AppendToObj(Tcl_GetObjResult(interp), s, -1); + Tcl_SetErrorCode(interp, "ARITH", "OVERFLOW", s, (char *) NULL); + } + } else { /* FAILS IF STRING REP CONTAINS NULLS */ + char msg[100]; + + sprintf(msg, "unknown floating-point error, errno = %d", errno); + Tcl_AppendToObj(Tcl_GetObjResult(interp), msg, -1); + Tcl_SetErrorCode(interp, "ARITH", "UNKNOWN", msg, (char *) NULL); + } +} + +#ifdef TCL_COMPILE_STATS +/* + *---------------------------------------------------------------------- + * + * TclLog2 -- + * + * Procedure used while collecting compilation statistics to determine + * the log base 2 of an integer. + * + * Results: + * Returns the log base 2 of the operand. If the argument is less + * than or equal to zero, a zero is returned. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TclLog2(value) + register int value; /* The integer for which to compute the + * log base 2. */ +{ + register int n = value; + register int result = 0; + + while (n > 1) { + n = n >> 1; + result++; + } + return result; +} + +/* + *---------------------------------------------------------------------- + * + * EvalStatsCmd -- + * + * Implements the "evalstats" command that prints instruction execution + * counts to stdout. + * + * Results: + * Standard Tcl results. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +EvalStatsCmd(unused, interp, argc, argv) + ClientData unused; /* Unused. */ + Tcl_Interp *interp; /* The current interpreter. */ + int argc; /* The number of arguments. */ + char **argv; /* The argument strings. */ +{ + register double total = 0.0; + register int i; + int maxSizeDecade = 0; + double totalHeaderBytes = (tclNumCompilations * sizeof(ByteCode)); + + for (i = 0; i < 256; i++) { + if (instructionCount[i] != 0) { + total += instructionCount[i]; + } + } + + for (i = 31; i >= 0; i--) { + if ((tclSourceCount[i] > 0) && (tclByteCodeCount[i] > 0)) { + maxSizeDecade = i; + break; + } + } + + fprintf(stdout, "\nNumber of compilations %ld\n", + tclNumCompilations); + fprintf(stdout, "Number of executions %ld\n", + numExecutions); + fprintf(stdout, "Average executions/compilation %.0f\n", + ((float) numExecutions/tclNumCompilations)); + + fprintf(stdout, "\nInstructions executed %.0f\n", + total); + fprintf(stdout, "Average instructions/compile %.0f\n", + total/tclNumCompilations); + fprintf(stdout, "Average instructions/execution %.0f\n", + total/numExecutions); + + fprintf(stdout, "\nTotal source bytes %.6g\n", + tclTotalSourceBytes); + fprintf(stdout, "Total code bytes %.6g\n", + tclTotalCodeBytes); + fprintf(stdout, "Average code/compilation %.0f\n", + tclTotalCodeBytes/tclNumCompilations); + fprintf(stdout, "Average code/source %.2f\n", + tclTotalCodeBytes/tclTotalSourceBytes); + fprintf(stdout, "Current source bytes %.6g\n", + tclCurrentSourceBytes); + fprintf(stdout, "Current code bytes %.6g\n", + tclCurrentCodeBytes); + fprintf(stdout, "Current code/source %.2f\n", + tclCurrentCodeBytes/tclCurrentSourceBytes); + + fprintf(stdout, "\nTotal objects allocated %ld\n", + tclObjsAlloced); + fprintf(stdout, "Total objects freed %ld\n", + tclObjsFreed); + fprintf(stdout, "Current objects: %ld\n", + (tclObjsAlloced - tclObjsFreed)); + + fprintf(stdout, "\nBreakdown of code byte requirements:\n"); + fprintf(stdout, " Total bytes Pct of Avg per\n"); + fprintf(stdout, " all code compile\n"); + fprintf(stdout, "Total code %12.6g 100%% %8.2f\n", + tclTotalCodeBytes, tclTotalCodeBytes/tclNumCompilations); + fprintf(stdout, "Header %12.6g %8.2f%% %8.2f\n", + totalHeaderBytes, + ((totalHeaderBytes * 100.0) / tclTotalCodeBytes), + totalHeaderBytes/tclNumCompilations); + fprintf(stdout, "Instructions %12.6g %8.2f%% %8.2f\n", + tclTotalInstBytes, + ((tclTotalInstBytes * 100.0) / tclTotalCodeBytes), + tclTotalInstBytes/tclNumCompilations); + fprintf(stdout, "Objects %12.6g %8.2f%% %8.2f\n", + tclTotalObjBytes, + ((tclTotalObjBytes * 100.0) / tclTotalCodeBytes), + tclTotalObjBytes/tclNumCompilations); + fprintf(stdout, "Exception table %12.6g %8.2f%% %8.2f\n", + tclTotalExceptBytes, + ((tclTotalExceptBytes * 100.0) / tclTotalCodeBytes), + tclTotalExceptBytes/tclNumCompilations); + fprintf(stdout, "Auxiliary data %12.6g %8.2f%% %8.2f\n", + tclTotalAuxBytes, + ((tclTotalAuxBytes * 100.0) / tclTotalCodeBytes), + tclTotalAuxBytes/tclNumCompilations); + fprintf(stdout, "Command map %12.6g %8.2f%% %8.2f\n", + tclTotalCmdMapBytes, + ((tclTotalCmdMapBytes * 100.0) / tclTotalCodeBytes), + tclTotalCmdMapBytes/tclNumCompilations); + + fprintf(stdout, "\nSource and ByteCode size distributions:\n"); + fprintf(stdout, " binary decade source code\n"); + for (i = 0; i <= maxSizeDecade; i++) { + int decadeLow, decadeHigh; + + if (i == 0) { + decadeLow = 0; + } else { + decadeLow = 1 << i; + } + decadeHigh = (1 << (i+1)) - 1; + fprintf(stdout, " %6d -%6d %6d %6d\n", + decadeLow, decadeHigh, + tclSourceCount[i], tclByteCodeCount[i]); + } + + fprintf(stdout, "\nInstruction counts:\n"); + for (i = 0; i < 256; i++) { + if (instructionCount[i]) { + fprintf(stdout, "%20s %8d %6.2f%%\n", + opName[i], instructionCount[i], + (instructionCount[i] * 100.0)/total); + } + } + +#ifdef TCL_MEM_DEBUG + fprintf(stdout, "\nHeap Statistics:\n"); + TclDumpMemoryInfo(stdout); +#endif /* TCL_MEM_DEBUG */ + + return TCL_OK; +} +#endif /* TCL_COMPILE_STATS */ + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetCommandFromObj -- + * + * Returns the command specified by the name in a Tcl_Obj. + * + * Results: + * Returns a token for the command if it is found. Otherwise, if it + * can't be found or there is an error, returns NULL. + * + * Side effects: + * May update the internal representation for the object, caching + * the command reference so that the next time this procedure is + * called with the same object, the command can be found quickly. + * + *---------------------------------------------------------------------- + */ + +Tcl_Command +Tcl_GetCommandFromObj(interp, objPtr) + Tcl_Interp *interp; /* The interpreter in which to resolve the + * command and to report errors. */ + register Tcl_Obj *objPtr; /* The object containing the command's + * name. If the name starts with "::", will + * be looked up in global namespace. Else, + * looked up first in the current namespace + * if contextNsPtr is NULL, then in global + * namespace. */ +{ + Interp *iPtr = (Interp *) interp; + register ResolvedCmdName *resPtr; + register Command *cmdPtr; + Namespace *currNsPtr; + int result; + + /* + * Get the internal representation, converting to a command type if + * needed. The internal representation is a ResolvedCmdName that points + * to the actual command. + */ + + if (objPtr->typePtr != &tclCmdNameType) { + result = tclCmdNameType.setFromAnyProc(interp, objPtr); + if (result != TCL_OK) { + return (Tcl_Command) NULL; + } + } + resPtr = (ResolvedCmdName *) objPtr->internalRep.otherValuePtr; + + /* + * Get the current namespace. + */ + + if (iPtr->varFramePtr != NULL) { + currNsPtr = iPtr->varFramePtr->nsPtr; + } else { + currNsPtr = iPtr->globalNsPtr; + } + + /* + * Check the context namespace and the namespace epoch of the resolved + * symbol to make sure that it is fresh. If not, then force another + * conversion to the command type, to discard the old rep and create a + * new one. Note that we verify that the namespace id of the context + * namespace is the same as the one we cached; this insures that the + * namespace wasn't deleted and a new one created at the same address + * with the same command epoch. + */ + + cmdPtr = NULL; + if ((resPtr != NULL) + && (resPtr->refNsPtr == currNsPtr) + && (resPtr->refNsId == currNsPtr->nsId) + && (resPtr->refNsCmdEpoch == currNsPtr->cmdRefEpoch)) { + cmdPtr = resPtr->cmdPtr; + if (cmdPtr->cmdEpoch != resPtr->cmdEpoch) { + cmdPtr = NULL; + } + } + + if (cmdPtr == NULL) { + result = tclCmdNameType.setFromAnyProc(interp, objPtr); + if (result != TCL_OK) { + return (Tcl_Command) NULL; + } + resPtr = (ResolvedCmdName *) objPtr->internalRep.otherValuePtr; + if (resPtr != NULL) { + cmdPtr = resPtr->cmdPtr; + } + } + + if (cmdPtr == NULL) { + return (Tcl_Command) NULL; + } + return (Tcl_Command) cmdPtr; +} + +/* + *---------------------------------------------------------------------- + * + * FreeCmdNameInternalRep -- + * + * Frees the resources associated with a cmdName object's internal + * representation. + * + * Results: + * None. + * + * Side effects: + * Decrements the ref count of any cached ResolvedCmdName structure + * pointed to by the cmdName's internal representation. If this is + * the last use of the ResolvedCmdName, it is freed. This in turn + * decrements the ref count of the Command structure pointed to by + * the ResolvedSymbol, which may free the Command structure. + * + *---------------------------------------------------------------------- + */ + +static void +FreeCmdNameInternalRep(objPtr) + register Tcl_Obj *objPtr; /* CmdName object with internal + * representation to free. */ +{ + register ResolvedCmdName *resPtr = + (ResolvedCmdName *) objPtr->internalRep.otherValuePtr; + + if (resPtr != NULL) { + /* + * Decrement the reference count of the ResolvedCmdName structure. + * If there are no more uses, free the ResolvedCmdName structure. + */ + + resPtr->refCount--; + if (resPtr->refCount == 0) { + /* + * Now free the cached command, unless it is still in its + * hash table or if there are other references to it + * from other cmdName objects. + */ + + Command *cmdPtr = resPtr->cmdPtr; + TclCleanupCommand(cmdPtr); + ckfree((char *) resPtr); + } + } +} + +/* + *---------------------------------------------------------------------- + * + * DupCmdNameInternalRep -- + * + * Initialize the internal representation of an cmdName Tcl_Obj to a + * copy of the internal representation of an existing cmdName object. + * + * Results: + * None. + * + * Side effects: + * "copyPtr"s internal rep is set to point to the ResolvedCmdName + * structure corresponding to "srcPtr"s internal rep. Increments the + * ref count of the ResolvedCmdName structure pointed to by the + * cmdName's internal representation. + * + *---------------------------------------------------------------------- + */ + +static void +DupCmdNameInternalRep(srcPtr, copyPtr) + Tcl_Obj *srcPtr; /* Object with internal rep to copy. */ + register Tcl_Obj *copyPtr; /* Object with internal rep to set. */ +{ + register ResolvedCmdName *resPtr = + (ResolvedCmdName *) srcPtr->internalRep.otherValuePtr; + + copyPtr->internalRep.twoPtrValue.ptr1 = (VOID *) resPtr; + copyPtr->internalRep.twoPtrValue.ptr2 = NULL; + if (resPtr != NULL) { + resPtr->refCount++; + } + copyPtr->typePtr = &tclCmdNameType; +} + +/* + *---------------------------------------------------------------------- + * + * SetCmdNameFromAny -- + * + * Generate an cmdName internal form for the Tcl object "objPtr". + * + * Results: + * The return value is a standard Tcl result. The conversion always + * succeeds and TCL_OK is returned. + * + * Side effects: + * A pointer to a ResolvedCmdName structure that holds a cached pointer + * to the command with a name that matches objPtr's string rep is + * stored as objPtr's internal representation. This ResolvedCmdName + * pointer will be NULL if no matching command was found. The ref count + * of the cached Command's structure (if any) is also incremented. + * + *---------------------------------------------------------------------- + */ + +static int +SetCmdNameFromAny(interp, objPtr) + Tcl_Interp *interp; /* Used for error reporting if not NULL. */ + register Tcl_Obj *objPtr; /* The object to convert. */ +{ + Interp *iPtr = (Interp *) interp; + char *name; + Tcl_Command cmd; + register Command *cmdPtr; + Namespace *currNsPtr; + register ResolvedCmdName *resPtr; + + /* + * Get "objPtr"s string representation. Make it up-to-date if necessary. + */ + + name = objPtr->bytes; + if (name == NULL) { + name = Tcl_GetStringFromObj(objPtr, (int *) NULL); + } + + /* + * Find the Command structure, if any, that describes the command called + * "name". Build a ResolvedCmdName that holds a cached pointer to this + * Command, and bump the reference count in the referenced Command + * structure. A Command structure will not be deleted as long as it is + * referenced from a CmdName object. + */ + + cmd = Tcl_FindCommand(interp, name, (Tcl_Namespace *) NULL, + /*flags*/ 0); + cmdPtr = (Command *) cmd; + if (cmdPtr != NULL) { + /* + * Get the current namespace. + */ + + if (iPtr->varFramePtr != NULL) { + currNsPtr = iPtr->varFramePtr->nsPtr; + } else { + currNsPtr = iPtr->globalNsPtr; + } + + cmdPtr->refCount++; + resPtr = (ResolvedCmdName *) ckalloc(sizeof(ResolvedCmdName)); + resPtr->cmdPtr = cmdPtr; + resPtr->refNsPtr = currNsPtr; + resPtr->refNsId = currNsPtr->nsId; + resPtr->refNsCmdEpoch = currNsPtr->cmdRefEpoch; + resPtr->cmdEpoch = cmdPtr->cmdEpoch; + resPtr->refCount = 1; + } else { + resPtr = NULL; /* no command named "name" was found */ + } + + /* + * Free the old internalRep before setting the new one. We do this as + * late as possible to allow the conversion code, in particular + * GetStringFromObj, to use that old internalRep. If no Command + * structure was found, leave NULL as the cached value. + */ + + if ((objPtr->typePtr != NULL) + && (objPtr->typePtr->freeIntRepProc != NULL)) { + objPtr->typePtr->freeIntRepProc(objPtr); + } + + objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) resPtr; + objPtr->internalRep.twoPtrValue.ptr2 = NULL; + objPtr->typePtr = &tclCmdNameType; + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * UpdateStringOfCmdName -- + * + * Update the string representation for an cmdName object. + * + * Results: + * None. + * + * Side effects: + * Generates a panic. + * + *---------------------------------------------------------------------- + */ + +static void +UpdateStringOfCmdName(objPtr) + Tcl_Obj *objPtr; /* CmdName obj to update string rep. */ +{ + /* + * This procedure is never invoked since the internal representation of + * a cmdName object is never modified. + */ + + panic("UpdateStringOfCmdName should never be invoked"); +} + +#ifdef TCL_COMPILE_DEBUG +/* + *---------------------------------------------------------------------- + * + * StringForResultCode -- + * + * Procedure that returns a human-readable string representing a + * Tcl result code such as TCL_ERROR. + * + * Results: + * If the result code is one of the standard Tcl return codes, the + * result is a string representing that code such as "TCL_ERROR". + * Otherwise, the result string is that code formatted as a + * sequence of decimal digit characters. Note that the resulting + * string must not be modified by the caller. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static char * +StringForResultCode(result) + int result; /* The Tcl result code for which to + * generate a string. */ +{ + static char buf[20]; + + if ((result >= TCL_OK) && (result <= TCL_CONTINUE)) { + return resultStrings[result]; + } + TclFormatInt(buf, result); + return buf; +} +#endif /* TCL_COMPILE_DEBUG */ |