diff options
Diffstat (limited to 'generic/tclExecute.c')
| -rw-r--r-- | generic/tclExecute.c | 11674 |
1 files changed, 4668 insertions, 7006 deletions
diff --git a/generic/tclExecute.c b/generic/tclExecute.c index e402634..3ca1b63 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -1,49 +1,63 @@ -/* +/* * tclExecute.c -- * - * This file contains procedures that execute byte-compiled Tcl commands. + * This file contains procedures that execute byte-compiled Tcl + * commands. * * Copyright (c) 1996-1997 Sun Microsystems, Inc. * Copyright (c) 1998-2000 by Scriptics Corporation. - * Copyright (c) 2001 by Kevin B. Kenny. All rights reserved. - * Copyright (c) 2002-2010 by Miguel Sofer. - * Copyright (c) 2005-2007 by Donal K. Fellows. - * Copyright (c) 2007 Daniel A. Steffen <das@users.sourceforge.net> - * Copyright (c) 2006-2008 by Joe Mistachkin. All rights reserved. + * Copyright (c) 2001 by Kevin B. Kenny. All rights reserved. * - * See the file "license.terms" for information on usage and redistribution of - * this file, and for a DISCLAIMER OF ALL WARRANTIES. + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" #include "tclCompile.h" -#include "tommath.h" -#include <math.h> -#if NRE_ENABLE_ASSERTS -#include <assert.h> +#ifndef TCL_NO_MATH +# include "tclMath.h" #endif /* - * Hack to determine whether we may expect IEEE floating point. The hack is - * formally incorrect in that non-IEEE platforms might have the same precision - * and range, but VAX, IBM, and Cray do not; are there any other floating - * point units that we might care about? + * 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. */ -#if (FLT_RADIX == 2) && (DBL_MANT_DIG == 53) && (DBL_MAX_EXP == 1024) -#define IEEE_FLOATING_POINT +#ifndef TCL_GENERIC_ONLY +# include "tclPort.h" +#else /* TCL_GENERIC_ONLY */ +# ifndef NO_FLOAT_H +# include <float.h> +# else /* NO_FLOAT_H */ +# ifndef NO_VALUES_H +# include <values.h> +# endif /* !NO_VALUES_H */ +# endif /* !NO_FLOAT_H */ +# define NO_ERRNO_H +#endif /* !TCL_GENERIC_ONLY */ + +#ifdef NO_ERRNO_H +int errno; +# define EDOM 33 +# define ERANGE 34 #endif /* - * A mask (should be 2**n-1) that is used to work out when the bytecode engine - * should call Tcl_AsyncReady() to see whether there is a signal that needs - * handling. + * Need DBL_MAX for IS_INF() macro... */ - -#ifndef ASYNC_CHECK_COUNT_MASK -# define ASYNC_CHECK_COUNT_MASK 63 -#endif /* !ASYNC_CHECK_COUNT_MASK */ +#ifndef DBL_MAX +# ifdef MAXDOUBLE +# define DBL_MAX MAXDOUBLE +# else /* !MAXDOUBLE */ +/* + * This value is from the Solaris headers, but doubles seem to be the + * same size everywhere. Long doubles aren't, but we don't use those. + */ +# define DBL_MAX 1.79769313486231570e+308 +# endif /* MAXDOUBLE */ +#endif /* !DBL_MAX */ /* * Boolean flag indicating whether the Tcl bytecode interpreter has been @@ -53,8 +67,6 @@ static int execInitialized = 0; TCL_DECLARE_MUTEX(execMutex) -static int cachedInExit = 0; - #ifdef TCL_COMPILE_DEBUG /* * Variable that controls whether execution tracing is enabled and, if so, @@ -73,25 +85,22 @@ int tclTraceExec = 0; * 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. - * - * Does not include the string for INST_EXPON (and beyond), as that is - * disjoint for backward-compatability reasons. */ -static const char *const operatorStrings[] = { +static CONST char *CONST operatorStrings[] = { "||", "&&", "|", "^", "&", "==", "!=", "<", ">", "<=", ">=", "<<", ">>", "+", "-", "*", "/", "%", "+", "-", "~", "!", "BUILTIN FUNCTION", "FUNCTION", - "", "", "", "", "", "", "", "", "eq", "ne" + "", "", "", "", "", "", "", "", "eq", "ne", }; /* * Mapping from Tcl result codes to strings; used for error and debugging - * messages. + * messages. */ #ifdef TCL_COMPILE_DEBUG -static const char *const resultStrings[] = { +static CONST char *CONST resultStrings[] = { "TCL_OK", "TCL_ERROR", "TCL_RETURN", "TCL_BREAK", "TCL_CONTINUE" }; #endif @@ -102,282 +111,147 @@ static const char *const resultStrings[] = { #ifdef TCL_COMPILE_STATS long tclObjsAlloced = 0; -long tclObjsFreed = 0; +long tclObjsFreed = 0; +#define TCL_MAX_SHARED_OBJ_STATS 5 long tclObjsShared[TCL_MAX_SHARED_OBJ_STATS] = { 0, 0, 0, 0, 0 }; #endif /* TCL_COMPILE_STATS */ /* - * Support pre-8.5 bytecodes unless specifically requested otherwise. + * 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. */ -#ifndef TCL_SUPPORT_84_BYTECODE -#define TCL_SUPPORT_84_BYTECODE 1 -#endif +#define IS_NAN(v) ((v) != (v)) +#define IS_INF(v) (((v) > DBL_MAX) || ((v) < -DBL_MAX)) -#if TCL_SUPPORT_84_BYTECODE /* - * We need to know the tclBuiltinFuncTable to support translation of pre-8.5 - * math functions to the namespace-based ::tcl::mathfunc::op in 8.5+. - */ - -typedef struct { - const char *name; /* Name of function. */ - int numArgs; /* Number of arguments for function. */ -} BuiltinFunc; - -/* - * 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. - */ - -static BuiltinFunc const tclBuiltinFuncTable[] = { - {"acos", 1}, - {"asin", 1}, - {"atan", 1}, - {"atan2", 2}, - {"ceil", 1}, - {"cos", 1}, - {"cosh", 1}, - {"exp", 1}, - {"floor", 1}, - {"fmod", 2}, - {"hypot", 2}, - {"log", 1}, - {"log10", 1}, - {"pow", 2}, - {"sin", 1}, - {"sinh", 1}, - {"sqrt", 1}, - {"tan", 1}, - {"tanh", 1}, - {"abs", 1}, - {"double", 1}, - {"int", 1}, - {"rand", 0}, - {"round", 1}, - {"srand", 1}, - {"wide", 1}, - {NULL, 0}, -}; - -#define LAST_BUILTIN_FUNC 25 -#endif - -/* - * NR_TEBC - * Helpers for NR - non-recursive calls to TEBC - * Minimal data required to fully reconstruct the execution state. - */ - -typedef struct TEBCdata { - ByteCode *codePtr; /* Constant until the BC returns */ - /* -----------------------------------------*/ - const unsigned char *pc; /* These fields are used on return TO this */ - ptrdiff_t *catchTop; /* this level: they record the state when a */ - int cleanup; /* new codePtr was received for NR */ - Tcl_Obj *auxObjList; /* execution. */ - int checkInterp; - CmdFrame cmdFrame; - void *stack[1]; /* Start of the actual combined catch and obj - * stacks; the struct will be expanded as - * necessary */ -} TEBCdata; - -#define TEBC_YIELD() \ - do { \ - esPtr->tosPtr = tosPtr; \ - TD->pc = pc; \ - TD->cleanup = cleanup; \ - TclNRAddCallback(interp, TEBCresume, TD, INT2PTR(1), NULL, NULL); \ - } while (0) - -#define TEBC_DATA_DIG() \ - do { \ - pc = TD->pc; \ - cleanup = TD->cleanup; \ - tosPtr = esPtr->tosPtr; \ - } while (0) - -#define PUSH_TAUX_OBJ(objPtr) \ - do { \ - objPtr->internalRep.ptrAndLongRep.ptr = auxObjList; \ - auxObjList = objPtr; \ - } while (0) - -#define POP_TAUX_OBJ() \ - do { \ - tmpPtr = auxObjList; \ - auxObjList = tmpPtr->internalRep.ptrAndLongRep.ptr; \ - Tcl_DecrRefCount(tmpPtr); \ - } while (0) - -/* - * These variable-access macros have to coincide with those in tclVar.c - */ - -#define VarHashGetValue(hPtr) \ - ((Var *) ((char *)hPtr - TclOffset(VarInHash, entry))) - -static inline Var * -VarHashCreateVar( - TclVarHashTable *tablePtr, - Tcl_Obj *key, - int *newPtr) -{ - Tcl_HashEntry *hPtr = Tcl_CreateHashEntry(&tablePtr->table, - key, newPtr); - - if (!hPtr) { - return NULL; - } - return VarHashGetValue(hPtr); -} - -#define VarHashFindVar(tablePtr, key) \ - VarHashCreateVar((tablePtr), (key), NULL) - -/* - * The new macro for ending an instruction; note that a reasonable C-optimiser - * will resolve all branches at compile time. (result) is always a constant; - * the macro NEXT_INST_F handles constant (nCleanup), NEXT_INST_V is resolved - * at runtime for variable (nCleanup). + * The new macro for ending an instruction; note that a + * reasonable C-optimiser will resolve all branches + * at compile time. (result) is always a constant; the macro + * NEXT_INST_F handles constant (nCleanup), NEXT_INST_V is + * resolved at runtime for variable (nCleanup). * * ARGUMENTS: * pcAdjustment: how much to increment pc * nCleanup: how many objects to remove from the stack - * resultHandling: 0 indicates no object should be pushed on the stack; - * otherwise, push objResultPtr. If (result < 0), objResultPtr already - * has the correct reference count. - * - * We use the new compile-time assertions to cheack that nCleanup is constant - * and within range. + * result: 0 indicates no object should be pushed on the + * stack; otherwise, push objResultPtr. If (result < 0), + * objResultPtr already has the correct reference count. */ -#define NEXT_INST_F(pcAdjustment, nCleanup, resultHandling) \ - do { \ - TCL_CT_ASSERT((nCleanup >= 0) && (nCleanup <= 2)); \ - if (nCleanup == 0) { \ - if (resultHandling != 0) { \ - if ((resultHandling) > 0) { \ - PUSH_OBJECT(objResultPtr); \ - } else { \ - *(++tosPtr) = objResultPtr; \ - } \ - } \ - pc += (pcAdjustment); \ - goto cleanup0; \ - } else if (resultHandling != 0) { \ - if ((resultHandling) > 0) { \ - Tcl_IncrRefCount(objResultPtr); \ - } \ - pc += (pcAdjustment); \ - switch (nCleanup) { \ - case 1: goto cleanup1_pushObjResultPtr; \ - case 2: goto cleanup2_pushObjResultPtr; \ - } \ - } else { \ - pc += (pcAdjustment); \ - switch (nCleanup) { \ - case 1: goto cleanup1; \ - case 2: goto cleanup2; \ - } \ - } \ - } while (0) - -#define NEXT_INST_V(pcAdjustment, nCleanup, resultHandling) \ - do { \ - pc += (pcAdjustment); \ - cleanup = (nCleanup); \ - if (resultHandling) { \ - if ((resultHandling) > 0) { \ - Tcl_IncrRefCount(objResultPtr); \ - } \ - goto cleanupV_pushObjResultPtr; \ - } else { \ - goto cleanupV; \ - } \ - } while (0) +#define NEXT_INST_F(pcAdjustment, nCleanup, result) \ + if (nCleanup == 0) {\ + if (result != 0) {\ + if ((result) > 0) {\ + PUSH_OBJECT(objResultPtr);\ + } else {\ + stackPtr[++stackTop] = objResultPtr;\ + }\ + } \ + pc += (pcAdjustment);\ + goto cleanup0;\ + } else if (result != 0) {\ + if ((result) > 0) {\ + Tcl_IncrRefCount(objResultPtr);\ + }\ + pc += (pcAdjustment);\ + switch (nCleanup) {\ + case 1: goto cleanup1_pushObjResultPtr;\ + case 2: goto cleanup2_pushObjResultPtr;\ + default: panic("ERROR: bad usage of macro NEXT_INST_F");\ + }\ + } else {\ + pc += (pcAdjustment);\ + switch (nCleanup) {\ + case 1: goto cleanup1;\ + case 2: goto cleanup2;\ + default: panic("ERROR: bad usage of macro NEXT_INST_F");\ + }\ + } + +#define NEXT_INST_V(pcAdjustment, nCleanup, result) \ + pc += (pcAdjustment);\ + cleanup = (nCleanup);\ + if (result) {\ + if ((result) > 0) {\ + Tcl_IncrRefCount(objResultPtr);\ + }\ + goto cleanupV_pushObjResultPtr;\ + } else {\ + goto cleanupV;\ + } + /* * 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 TclNRExecuteByteCode (and a few other + * pair must surround any call inside TclExecuteByteCode (and a few other * procedures that use this scheme) that could result in a recursive call - * to TclNRExecuteByteCode. + * to TclExecuteByteCode. */ #define CACHE_STACK_INFO() \ - checkInterp = 1 + stackPtr = eePtr->stackPtr; \ + stackTop = eePtr->stackTop #define DECACHE_STACK_INFO() \ - esPtr->tosPtr = tosPtr + 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. + * 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. * * 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. + * 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(*(++tosPtr) = (objPtr)) - -#define POP_OBJECT() *(tosPtr--) - -#define OBJ_AT_TOS *tosPtr - -#define OBJ_UNDER_TOS *(tosPtr-1) - -#define OBJ_AT_DEPTH(n) *(tosPtr-(n)) - -#define CURR_DEPTH ((ptrdiff_t) (tosPtr - initTosPtr)) + Tcl_IncrRefCount(stackPtr[++stackTop] = (objPtr)) + +#define POP_OBJECT() \ + (stackPtr[stackTop--]) /* * Macros used to trace instruction execution. The macros TRACE, - * TRACE_WITH_OBJ, and O2S are only used inside TclNRExecuteByteCode. O2S is - * only used in TRACE* calls to get a string from an object. + * TRACE_WITH_OBJ, and O2S are only used inside TclExecuteByteCode. + * O2S is only used in TRACE* calls to get a string from an object. */ #ifdef TCL_COMPILE_DEBUG # define TRACE(a) \ - while (traceInstructions) { \ - fprintf(stdout, "%2d: %2d (%u) %s ", iPtr->numLevels, \ - (int) CURR_DEPTH, \ - (unsigned) (pc - codePtr->codeStart), \ - GetOpcodeName(pc)); \ - printf a; \ - break; \ + if (traceInstructions) { \ + fprintf(stdout, "%2d: %2d (%u) %s ", iPtr->numLevels, stackTop, \ + (unsigned int)(pc - codePtr->codeStart), \ + GetOpcodeName(pc)); \ + printf a; \ } # define TRACE_APPEND(a) \ - while (traceInstructions) { \ - printf a; \ - break; \ + if (traceInstructions) { \ + printf a; \ } # define TRACE_WITH_OBJ(a, objPtr) \ - while (traceInstructions) { \ - fprintf(stdout, "%2d: %2d (%u) %s ", iPtr->numLevels, \ - (int) CURR_DEPTH, \ - (unsigned) (pc - codePtr->codeStart), \ - GetOpcodeName(pc)); \ - printf a; \ - TclPrintObject(stdout, objPtr, 30); \ - fprintf(stdout, "\n"); \ - break; \ + if (traceInstructions) { \ + fprintf(stdout, "%2d: %2d (%u) %s ", iPtr->numLevels, stackTop, \ + (unsigned int)(pc - codePtr->codeStart), \ + GetOpcodeName(pc)); \ + printf a; \ + TclPrintObject(stdout, objPtr, 30); \ + fprintf(stdout, "\n"); \ } # define O2S(objPtr) \ (objPtr ? TclGetString(objPtr) : "") #else /* !TCL_COMPILE_DEBUG */ # define TRACE(a) -# define TRACE_APPEND(a) +# define TRACE_APPEND(a) # define TRACE_WITH_OBJ(a, objPtr) # define O2S(objPtr) #endif /* TCL_COMPILE_DEBUG */ @@ -387,343 +261,156 @@ VarHashCreateVar( */ #define TCL_DTRACE_INST_NEXT() \ - do { \ - if (TCL_DTRACE_INST_DONE_ENABLED()) { \ - if (curInstName) { \ - TCL_DTRACE_INST_DONE(curInstName, (int) CURR_DEPTH, \ - tosPtr); \ - } \ - curInstName = tclInstructionTable[*pc].name; \ - if (TCL_DTRACE_INST_START_ENABLED()) { \ - TCL_DTRACE_INST_START(curInstName, (int) CURR_DEPTH, \ - tosPtr); \ - } \ - } else if (TCL_DTRACE_INST_START_ENABLED()) { \ - TCL_DTRACE_INST_START(tclInstructionTable[*pc].name, \ - (int) CURR_DEPTH, tosPtr); \ - } \ - } while (0) + if (TCL_DTRACE_INST_DONE_ENABLED()) {\ + if (curInstName) {\ + TCL_DTRACE_INST_DONE(curInstName, stackTop - initStackTop,\ + stackPtr + stackTop);\ + }\ + curInstName = tclInstructionTable[*pc].name;\ + if (TCL_DTRACE_INST_START_ENABLED()) {\ + TCL_DTRACE_INST_START(curInstName, stackTop - initStackTop,\ + stackPtr + stackTop);\ + }\ + } else if (TCL_DTRACE_INST_START_ENABLED()) {\ + TCL_DTRACE_INST_START(tclInstructionTable[*pc].name,\ + stackTop - initStackTop, stackPtr + stackTop);\ + } #define TCL_DTRACE_INST_LAST() \ - do { \ - if (TCL_DTRACE_INST_DONE_ENABLED() && curInstName) { \ - TCL_DTRACE_INST_DONE(curInstName, (int) CURR_DEPTH, tosPtr);\ - } \ - } while (0) - -/* - * Macro used in this file to save a function call for common uses of - * TclGetNumberFromObj(). The ANSI C "prototype" is: - * - * MODULE_SCOPE int GetNumberFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, - * ClientData *ptrPtr, int *tPtr); - */ - -#ifdef NO_WIDE_TYPE -#define GetNumberFromObj(interp, objPtr, ptrPtr, tPtr) \ - (((objPtr)->typePtr == &tclIntType) \ - ? (*(tPtr) = TCL_NUMBER_LONG, \ - *(ptrPtr) = (ClientData) \ - (&((objPtr)->internalRep.longValue)), TCL_OK) : \ - ((objPtr)->typePtr == &tclDoubleType) \ - ? (((TclIsNaN((objPtr)->internalRep.doubleValue)) \ - ? (*(tPtr) = TCL_NUMBER_NAN) \ - : (*(tPtr) = TCL_NUMBER_DOUBLE)), \ - *(ptrPtr) = (ClientData) \ - (&((objPtr)->internalRep.doubleValue)), TCL_OK) : \ - ((((objPtr)->typePtr == NULL) && ((objPtr)->bytes == NULL)) || \ - (((objPtr)->bytes != NULL) && ((objPtr)->length == 0))) \ - ? TCL_ERROR : \ - TclGetNumberFromObj((interp), (objPtr), (ptrPtr), (tPtr))) -#else /* !NO_WIDE_TYPE */ -#define GetNumberFromObj(interp, objPtr, ptrPtr, tPtr) \ - (((objPtr)->typePtr == &tclIntType) \ - ? (*(tPtr) = TCL_NUMBER_LONG, \ - *(ptrPtr) = (ClientData) \ - (&((objPtr)->internalRep.longValue)), TCL_OK) : \ - ((objPtr)->typePtr == &tclWideIntType) \ - ? (*(tPtr) = TCL_NUMBER_WIDE, \ - *(ptrPtr) = (ClientData) \ - (&((objPtr)->internalRep.wideValue)), TCL_OK) : \ - ((objPtr)->typePtr == &tclDoubleType) \ - ? (((TclIsNaN((objPtr)->internalRep.doubleValue)) \ - ? (*(tPtr) = TCL_NUMBER_NAN) \ - : (*(tPtr) = TCL_NUMBER_DOUBLE)), \ - *(ptrPtr) = (ClientData) \ - (&((objPtr)->internalRep.doubleValue)), TCL_OK) : \ - ((((objPtr)->typePtr == NULL) && ((objPtr)->bytes == NULL)) || \ - (((objPtr)->bytes != NULL) && ((objPtr)->length == 0))) \ - ? TCL_ERROR : \ - TclGetNumberFromObj((interp), (objPtr), (ptrPtr), (tPtr))) -#endif /* NO_WIDE_TYPE */ - -/* - * Macro used in this file to save a function call for common uses of - * Tcl_GetBooleanFromObj(). The ANSI C "prototype" is: - * - * MODULE_SCOPE int TclGetBooleanFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, - * int *boolPtr); - */ - -#define TclGetBooleanFromObj(interp, objPtr, boolPtr) \ - ((((objPtr)->typePtr == &tclIntType) \ - || ((objPtr)->typePtr == &tclBooleanType)) \ - ? (*(boolPtr) = ((objPtr)->internalRep.longValue!=0), TCL_OK) \ - : Tcl_GetBooleanFromObj((interp), (objPtr), (boolPtr))) - -/* - * Macro used in this file to save a function call for common uses of - * Tcl_GetWideIntFromObj(). The ANSI C "prototype" is: - * - * MODULE_SCOPE int TclGetWideIntFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, - * Tcl_WideInt *wideIntPtr); - */ - -#ifdef NO_WIDE_TYPE -#define TclGetWideIntFromObj(interp, objPtr, wideIntPtr) \ - (((objPtr)->typePtr == &tclIntType) \ - ? (*(wideIntPtr) = (Tcl_WideInt) \ - ((objPtr)->internalRep.longValue), TCL_OK) : \ - Tcl_GetWideIntFromObj((interp), (objPtr), (wideIntPtr))) -#else /* !NO_WIDE_TYPE */ -#define TclGetWideIntFromObj(interp, objPtr, wideIntPtr) \ - (((objPtr)->typePtr == &tclWideIntType) \ - ? (*(wideIntPtr) = (objPtr)->internalRep.wideValue, TCL_OK) : \ - ((objPtr)->typePtr == &tclIntType) \ - ? (*(wideIntPtr) = (Tcl_WideInt) \ - ((objPtr)->internalRep.longValue), TCL_OK) : \ - Tcl_GetWideIntFromObj((interp), (objPtr), (wideIntPtr))) -#endif /* NO_WIDE_TYPE */ - -/* - * Macro used to make the check for type overflow more mnemonic. This works by - * comparing sign bits; the rest of the word is irrelevant. The ANSI C - * "prototype" (where inttype_t is any integer type) is: - * - * MODULE_SCOPE int Overflowing(inttype_t a, inttype_t b, inttype_t sum); - * - * Check first the condition most likely to fail in usual code (at least for - * usage in [incr]: do the first summand and the sum have != signs? - */ - -#define Overflowing(a,b,sum) ((((a)^(sum)) < 0) && (((a)^(b)) >= 0)) - -/* - * Macro for checking whether the type is NaN, used when we're thinking about - * throwing an error for supplying a non-number number. - */ - -#ifndef ACCEPT_NAN -#define IsErroringNaNType(type) ((type) == TCL_NUMBER_NAN) -#else -#define IsErroringNaNType(type) 0 -#endif - -/* - * Auxiliary tables used to compute powers of small integers. - */ - -#if (LONG_MAX == 0x7fffffff) - -/* - * Maximum base that, when raised to powers 2, 3, ... 8, fits in a 32-bit - * signed integer. - */ - -static const long MaxBase32[] = {46340, 1290, 215, 73, 35, 21, 14}; -static const size_t MaxBase32Size = sizeof(MaxBase32)/sizeof(long); + if (TCL_DTRACE_INST_DONE_ENABLED() && curInstName) {\ + TCL_DTRACE_INST_DONE(curInstName, stackTop - initStackTop,\ + stackPtr + stackTop);\ + } /* - * Table giving 3, 4, ..., 11, raised to the powers 9, 10, ..., as far as they - * fit in a 32-bit signed integer. Exp32Index[i] gives the starting index of - * powers of i+3; Exp32Value[i] gives the corresponding powers. + * Macro to read a string containing either a wide or an int and + * decide which it is while decoding it at the same time. This + * enforces the policy that integer constants between LONG_MIN and + * LONG_MAX (inclusive) are represented by normal longs, and integer + * constants outside that range are represented by wide ints. + * + * GET_WIDE_OR_INT is the same as REQUIRE_WIDE_OR_INT except it never + * generates an error message. */ - -static const unsigned short Exp32Index[] = { - 0, 11, 18, 23, 26, 29, 31, 32, 33 -}; -static const size_t Exp32IndexSize = - sizeof(Exp32Index) / sizeof(unsigned short); -static const long Exp32Value[] = { - 19683, 59049, 177147, 531441, 1594323, 4782969, 14348907, 43046721, - 129140163, 387420489, 1162261467, 262144, 1048576, 4194304, - 16777216, 67108864, 268435456, 1073741824, 1953125, 9765625, - 48828125, 244140625, 1220703125, 10077696, 60466176, 362797056, - 40353607, 282475249, 1977326743, 134217728, 1073741824, 387420489, - 1000000000 -}; -static const size_t Exp32ValueSize = sizeof(Exp32Value)/sizeof(long); -#endif /* LONG_MAX == 0x7fffffff -- 32 bit machine */ - -#if (LONG_MAX > 0x7fffffff) || !defined(TCL_WIDE_INT_IS_LONG) - +#define REQUIRE_WIDE_OR_INT(resultVar, objPtr, longVar, wideVar) \ + (resultVar) = Tcl_GetWideIntFromObj(interp, (objPtr), &(wideVar)); \ + if ((resultVar) == TCL_OK && (wideVar) >= Tcl_LongAsWide(LONG_MIN) \ + && (wideVar) <= Tcl_LongAsWide(LONG_MAX)) { \ + (objPtr)->typePtr = &tclIntType; \ + (objPtr)->internalRep.longValue = (longVar) \ + = Tcl_WideAsLong(wideVar); \ + } +#define GET_WIDE_OR_INT(resultVar, objPtr, longVar, wideVar) \ + (resultVar) = Tcl_GetWideIntFromObj((Tcl_Interp *) NULL, (objPtr), \ + &(wideVar)); \ + if ((resultVar) == TCL_OK && (wideVar) >= Tcl_LongAsWide(LONG_MIN) \ + && (wideVar) <= Tcl_LongAsWide(LONG_MAX)) { \ + (objPtr)->typePtr = &tclIntType; \ + (objPtr)->internalRep.longValue = (longVar) \ + = Tcl_WideAsLong(wideVar); \ + } /* - * Maximum base that, when raised to powers 2, 3, ..., 16, fits in a - * Tcl_WideInt. + * Combined with REQUIRE_WIDE_OR_INT, this gets a long value from + * an obj. */ +#define FORCE_LONG(objPtr, longVar, wideVar) \ + if ((objPtr)->typePtr == &tclWideIntType) { \ + (longVar) = Tcl_WideAsLong(wideVar); \ + } +#define IS_INTEGER_TYPE(typePtr) \ + ((typePtr) == &tclIntType || (typePtr) == &tclWideIntType) +#define IS_NUMERIC_TYPE(typePtr) \ + (IS_INTEGER_TYPE(typePtr) || (typePtr) == &tclDoubleType) -static const Tcl_WideInt MaxBase64[] = { - (Tcl_WideInt)46340*65536+62259, /* 3037000499 == isqrt(2**63-1) */ - (Tcl_WideInt)2097151, (Tcl_WideInt)55108, (Tcl_WideInt)6208, - (Tcl_WideInt)1448, (Tcl_WideInt)511, (Tcl_WideInt)234, (Tcl_WideInt)127, - (Tcl_WideInt)78, (Tcl_WideInt)52, (Tcl_WideInt)38, (Tcl_WideInt)28, - (Tcl_WideInt)22, (Tcl_WideInt)18, (Tcl_WideInt)15 -}; -static const size_t MaxBase64Size = sizeof(MaxBase64)/sizeof(Tcl_WideInt); - +#define W0 Tcl_LongAsWide(0) /* - * Table giving 3, 4, ..., 13 raised to powers greater than 16 when the - * results fit in a 64-bit signed integer. + * For tracing that uses wide values. */ +#define LLD "%" TCL_LL_MODIFIER "d" -static const unsigned short Exp64Index[] = { - 0, 23, 38, 49, 57, 63, 67, 70, 72, 74, 75, 76 -}; -static const size_t Exp64IndexSize = - sizeof(Exp64Index) / sizeof(unsigned short); -static const Tcl_WideInt Exp64Value[] = { - (Tcl_WideInt)243*243*243*3*3, - (Tcl_WideInt)243*243*243*3*3*3, - (Tcl_WideInt)243*243*243*3*3*3*3, - (Tcl_WideInt)243*243*243*243, - (Tcl_WideInt)243*243*243*243*3, - (Tcl_WideInt)243*243*243*243*3*3, - (Tcl_WideInt)243*243*243*243*3*3*3, - (Tcl_WideInt)243*243*243*243*3*3*3*3, - (Tcl_WideInt)243*243*243*243*243, - (Tcl_WideInt)243*243*243*243*243*3, - (Tcl_WideInt)243*243*243*243*243*3*3, - (Tcl_WideInt)243*243*243*243*243*3*3*3, - (Tcl_WideInt)243*243*243*243*243*3*3*3*3, - (Tcl_WideInt)243*243*243*243*243*243, - (Tcl_WideInt)243*243*243*243*243*243*3, - (Tcl_WideInt)243*243*243*243*243*243*3*3, - (Tcl_WideInt)243*243*243*243*243*243*3*3*3, - (Tcl_WideInt)243*243*243*243*243*243*3*3*3*3, - (Tcl_WideInt)243*243*243*243*243*243*243, - (Tcl_WideInt)243*243*243*243*243*243*243*3, - (Tcl_WideInt)243*243*243*243*243*243*243*3*3, - (Tcl_WideInt)243*243*243*243*243*243*243*3*3*3, - (Tcl_WideInt)243*243*243*243*243*243*243*3*3*3*3, - (Tcl_WideInt)1024*1024*1024*4*4, - (Tcl_WideInt)1024*1024*1024*4*4*4, - (Tcl_WideInt)1024*1024*1024*4*4*4*4, - (Tcl_WideInt)1024*1024*1024*1024, - (Tcl_WideInt)1024*1024*1024*1024*4, - (Tcl_WideInt)1024*1024*1024*1024*4*4, - (Tcl_WideInt)1024*1024*1024*1024*4*4*4, - (Tcl_WideInt)1024*1024*1024*1024*4*4*4*4, - (Tcl_WideInt)1024*1024*1024*1024*1024, - (Tcl_WideInt)1024*1024*1024*1024*1024*4, - (Tcl_WideInt)1024*1024*1024*1024*1024*4*4, - (Tcl_WideInt)1024*1024*1024*1024*1024*4*4*4, - (Tcl_WideInt)1024*1024*1024*1024*1024*4*4*4*4, - (Tcl_WideInt)1024*1024*1024*1024*1024*1024, - (Tcl_WideInt)1024*1024*1024*1024*1024*1024*4, - (Tcl_WideInt)3125*3125*3125*5*5, - (Tcl_WideInt)3125*3125*3125*5*5*5, - (Tcl_WideInt)3125*3125*3125*5*5*5*5, - (Tcl_WideInt)3125*3125*3125*3125, - (Tcl_WideInt)3125*3125*3125*3125*5, - (Tcl_WideInt)3125*3125*3125*3125*5*5, - (Tcl_WideInt)3125*3125*3125*3125*5*5*5, - (Tcl_WideInt)3125*3125*3125*3125*5*5*5*5, - (Tcl_WideInt)3125*3125*3125*3125*3125, - (Tcl_WideInt)3125*3125*3125*3125*3125*5, - (Tcl_WideInt)3125*3125*3125*3125*3125*5*5, - (Tcl_WideInt)7776*7776*7776*6*6, - (Tcl_WideInt)7776*7776*7776*6*6*6, - (Tcl_WideInt)7776*7776*7776*6*6*6*6, - (Tcl_WideInt)7776*7776*7776*7776, - (Tcl_WideInt)7776*7776*7776*7776*6, - (Tcl_WideInt)7776*7776*7776*7776*6*6, - (Tcl_WideInt)7776*7776*7776*7776*6*6*6, - (Tcl_WideInt)7776*7776*7776*7776*6*6*6*6, - (Tcl_WideInt)16807*16807*16807*7*7, - (Tcl_WideInt)16807*16807*16807*7*7*7, - (Tcl_WideInt)16807*16807*16807*7*7*7*7, - (Tcl_WideInt)16807*16807*16807*16807, - (Tcl_WideInt)16807*16807*16807*16807*7, - (Tcl_WideInt)16807*16807*16807*16807*7*7, - (Tcl_WideInt)32768*32768*32768*8*8, - (Tcl_WideInt)32768*32768*32768*8*8*8, - (Tcl_WideInt)32768*32768*32768*8*8*8*8, - (Tcl_WideInt)32768*32768*32768*32768, - (Tcl_WideInt)59049*59049*59049*9*9, - (Tcl_WideInt)59049*59049*59049*9*9*9, - (Tcl_WideInt)59049*59049*59049*9*9*9*9, - (Tcl_WideInt)100000*100000*100000*10*10, - (Tcl_WideInt)100000*100000*100000*10*10*10, - (Tcl_WideInt)161051*161051*161051*11*11, - (Tcl_WideInt)161051*161051*161051*11*11*11, - (Tcl_WideInt)248832*248832*248832*12*12, - (Tcl_WideInt)371293*371293*371293*13*13 -}; -static const size_t Exp64ValueSize = sizeof(Exp64Value) / sizeof(Tcl_WideInt); -#endif /* (LONG_MAX > 0x7fffffff) || !defined(TCL_WIDE_INT_IS_LONG) */ - +#ifndef TCL_WIDE_INT_IS_LONG /* - * Markers for ExecuteExtendedBinaryMathOp. + * Extract a double value from a general numeric object. */ +#define GET_DOUBLE_VALUE(doubleVar, objPtr, typePtr) \ + if ((typePtr) == &tclIntType) { \ + (doubleVar) = (double) (objPtr)->internalRep.longValue; \ + } else if ((typePtr) == &tclWideIntType) { \ + (doubleVar) = Tcl_WideAsDouble((objPtr)->internalRep.wideValue);\ + } else { \ + (doubleVar) = (objPtr)->internalRep.doubleValue; \ + } +#else /* TCL_WIDE_INT_IS_LONG */ +#define GET_DOUBLE_VALUE(doubleVar, objPtr, typePtr) \ + if (((typePtr) == &tclIntType) || ((typePtr) == &tclWideIntType)) { \ + (doubleVar) = (double) (objPtr)->internalRep.longValue; \ + } else { \ + (doubleVar) = (objPtr)->internalRep.doubleValue; \ + } +#endif /* TCL_WIDE_INT_IS_LONG */ -#define DIVIDED_BY_ZERO ((Tcl_Obj *) -1) -#define EXPONENT_OF_ZERO ((Tcl_Obj *) -2) -#define GENERAL_ARITHMETIC_ERROR ((Tcl_Obj *) -3) - /* * Declarations for local procedures to this file: */ +static int TclExecuteByteCode _ANSI_ARGS_((Tcl_Interp *interp, + ByteCode *codePtr)); +static void DupExprCodeInternalRep _ANSI_ARGS_((Tcl_Obj *srcPtr, + 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)); +static int ExprWideFunc _ANSI_ARGS_((Tcl_Interp *interp, + ExecEnv *eePtr, ClientData clientData)); #ifdef TCL_COMPILE_STATS -static int EvalStatsCmd(ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); +static int EvalStatsCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[])); #endif /* TCL_COMPILE_STATS */ +static void FreeExprCodeInternalRep _ANSI_ARGS_ ((Tcl_Obj *objPtr)); #ifdef TCL_COMPILE_DEBUG -static const char * GetOpcodeName(const unsigned char *pc); -static void PrintByteCodeInfo(ByteCode *codePtr); -static const char * StringForResultCode(int result); -static void ValidatePcAndStackTop(ByteCode *codePtr, - const unsigned char *pc, int stackTop, - int stackLowerBound, int checkStack); +static char * GetOpcodeName _ANSI_ARGS_((unsigned char *pc)); #endif /* TCL_COMPILE_DEBUG */ -static ByteCode * CompileExprObj(Tcl_Interp *interp, Tcl_Obj *objPtr); -static void DeleteExecStack(ExecStack *esPtr); -static void DupExprCodeInternalRep(Tcl_Obj *srcPtr, - Tcl_Obj *copyPtr); -MODULE_SCOPE int TclCompareTwoNumbers(Tcl_Obj *valuePtr, - Tcl_Obj *value2Ptr); -static Tcl_Obj * ExecuteExtendedBinaryMathOp(Tcl_Interp *interp, - int opcode, Tcl_Obj **constants, - Tcl_Obj *valuePtr, Tcl_Obj *value2Ptr); -static Tcl_Obj * ExecuteExtendedUnaryMathOp(int opcode, - Tcl_Obj *valuePtr); -static void FreeExprCodeInternalRep(Tcl_Obj *objPtr); -static ExceptionRange * GetExceptRangeForPc(const unsigned char *pc, - int catchOnly, ByteCode *codePtr); -static const char * GetSrcInfoForPc(const unsigned char *pc, - ByteCode *codePtr, int *lengthPtr, - const unsigned char **pcBeg); -static Tcl_Obj ** GrowEvaluationStack(ExecEnv *eePtr, int growth, - int move); -static void IllegalExprOperandType(Tcl_Interp *interp, - const unsigned char *pc, Tcl_Obj *opndPtr); -static void InitByteCodeExecution(Tcl_Interp *interp); -static inline int OFFSET(void *ptr); -static void ReleaseDictIterator(Tcl_Obj *objPtr); -/* Useful elsewhere, make available in tclInt.h or stubs? */ -static Tcl_Obj ** StackAllocWords(Tcl_Interp *interp, int numWords); -static Tcl_Obj ** StackReallocWords(Tcl_Interp *interp, int numWords); -static Tcl_NRPostProc CopyCallback; -static Tcl_NRPostProc ExprObjCallback; - -static Tcl_NRPostProc TEBCresume; +static ExceptionRange * GetExceptRangeForPc _ANSI_ARGS_((unsigned char *pc, + int catchOnly, ByteCode* codePtr)); +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 char *pc, + Tcl_Obj *opndPtr)); +static void InitByteCodeExecution _ANSI_ARGS_(( + Tcl_Interp *interp)); +#ifdef TCL_COMPILE_DEBUG +static void PrintByteCodeInfo _ANSI_ARGS_((ByteCode *codePtr)); +static CONST char * StringForResultCode _ANSI_ARGS_((int result)); +static void ValidatePcAndStackTop _ANSI_ARGS_(( + ByteCode *codePtr, unsigned char *pc, + int stackTop, int stackLowerBound)); +#endif /* TCL_COMPILE_DEBUG */ +static int VerifyExprObjType _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Obj *objPtr)); /* * The structure below defines a bytecode Tcl object type to hold the * compiled bytecode for Tcl expressions. */ -static const Tcl_ObjType exprCodeType = { +static Tcl_ObjType exprCodeType = { "exprcode", FreeExprCodeInternalRep, /* freeIntRepProc */ DupExprCodeInternalRep, /* dupIntRepProc */ @@ -732,58 +419,46 @@ static const Tcl_ObjType exprCodeType = { }; /* - * Custom object type only used in this file; values of its type should never - * be seen by user scripts. + * 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. */ -static const Tcl_ObjType dictIteratorType = { - "dictIterator", - ReleaseDictIterator, - NULL, NULL, NULL +BuiltinFunc tclBuiltinFuncTable[] = { +#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}, + {"wide", 1, {TCL_EITHER}, ExprWideFunc, 0}, + {0, 0, {TCL_INT}, 0, 0}, }; /* *---------------------------------------------------------------------- * - * ReleaseDictIterator -- - * - * This takes apart a dictionary iterator that is stored in the given Tcl - * object. - * - * Results: - * None. - * - * Side effects: - * Deallocates memory, marks the object as being untyped. - * - *---------------------------------------------------------------------- - */ - -static void -ReleaseDictIterator( - Tcl_Obj *objPtr) -{ - Tcl_DictSearch *searchPtr; - Tcl_Obj *dictPtr; - - /* - * First kill the search, and then release the reference to the dictionary - * that we were holding. - */ - - searchPtr = objPtr->internalRep.twoPtrValue.ptr1; - Tcl_DictObjDone(searchPtr); - ckfree(searchPtr); - - dictPtr = objPtr->internalRep.twoPtrValue.ptr2; - TclDecrRefCount(dictPtr); - - objPtr->typePtr = NULL; -} - -/* - *---------------------------------------------------------------------- - * * InitByteCodeExecution -- * * This procedure is called once to initialize the Tcl bytecode @@ -794,28 +469,29 @@ ReleaseDictIterator( * * 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 establishes the link between the Tcl - * "tcl_traceExec" and C "tclTraceExec" variables. + * 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 establishes the link + * between the Tcl "tcl_traceExec" and C "tclTraceExec" variables. * *---------------------------------------------------------------------- */ static void -InitByteCodeExecution( - Tcl_Interp *interp) /* Interpreter for which the Tcl variable +InitByteCodeExecution(interp) + Tcl_Interp *interp; /* Interpreter for which the Tcl variable * "tcl_traceExec" is linked to control * instruction tracing. */ { #ifdef TCL_COMPILE_DEBUG if (Tcl_LinkVar(interp, "tcl_traceExec", (char *) &tclTraceExec, - TCL_LINK_INT) != TCL_OK) { - Tcl_Panic("InitByteCodeExecution: can't create link for tcl_traceExec variable"); + TCL_LINK_INT) != TCL_OK) { + panic("InitByteCodeExecution: can't create link for tcl_traceExec variable"); } #endif -#ifdef TCL_COMPILE_STATS - Tcl_CreateObjCommand(interp, "evalstats", EvalStatsCmd, NULL, NULL); +#ifdef TCL_COMPILE_STATS + Tcl_CreateObjCommand(interp, "evalstats", EvalStatsCmd, + (ClientData) NULL, (Tcl_CmdDeleteProc *) NULL); #endif /* TCL_COMPILE_STATS */ } @@ -825,48 +501,52 @@ InitByteCodeExecution( * 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 TclNRExecuteByteCode to execute ByteCode sequences - * for nested commands. + * 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 TclNRExecuteByteCode. + * 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( - Tcl_Interp *interp, /* Interpreter for which the execution +TclCreateExecEnv(interp) + Tcl_Interp *interp; /* Interpreter for which the execution * environment is being created. */ - int size) /* The initial stack size, in number of words - * [sizeof(Tcl_Obj*)] */ { - ExecEnv *eePtr = ckalloc(sizeof(ExecEnv)); - ExecStack *esPtr = ckalloc(sizeof(ExecStack) - + (size_t) (size-1) * sizeof(Tcl_Obj *)); - - eePtr->execStackPtr = esPtr; - TclNewBooleanObj(eePtr->constants[0], 0); - Tcl_IncrRefCount(eePtr->constants[0]); - TclNewBooleanObj(eePtr->constants[1], 1); - Tcl_IncrRefCount(eePtr->constants[1]); - eePtr->interp = interp; - eePtr->callbackPtr = NULL; - eePtr->corPtr = NULL; - eePtr->rewind = 0; - - esPtr->prevPtr = NULL; - esPtr->nextPtr = NULL; - esPtr->markerPtr = NULL; - esPtr->endPtr = &esPtr->stackWords[size-1]; - esPtr->tosPtr = &esPtr->stackWords[-1]; + ExecEnv *eePtr = (ExecEnv *) ckalloc(sizeof(ExecEnv)); + Tcl_Obj **stackPtr; + + stackPtr = (Tcl_Obj **) + ckalloc((size_t) (TCL_STACK_INITIAL_SIZE * sizeof(Tcl_Obj *))); + + /* + * Use the bottom pointer to keep a reference count; the + * execution environment holds a reference. + */ + + stackPtr++; + eePtr->stackPtr = stackPtr; + stackPtr[-1] = (Tcl_Obj *) ((char *) 1); + + eePtr->stackTop = -1; + eePtr->stackEnd = (TCL_STACK_INITIAL_SIZE - 2); + + eePtr->errorInfo = Tcl_NewStringObj("::errorInfo", -1); + Tcl_IncrRefCount(eePtr->errorInfo); + + eePtr->errorCode = Tcl_NewStringObj("::errorCode", -1); + Tcl_IncrRefCount(eePtr->errorCode); Tcl_MutexLock(&execMutex); if (!execInitialized) { @@ -878,6 +558,7 @@ TclCreateExecEnv( return eePtr; } +#undef TCL_STACK_INITIAL_SIZE /* *---------------------------------------------------------------------- @@ -890,59 +571,24 @@ TclCreateExecEnv( * None. * * Side effects: - * Storage for an ExecEnv and its contained storage (e.g. the evaluation - * stack) is freed. + * Storage for an ExecEnv and its contained storage (e.g. the + * evaluation stack) is freed. * *---------------------------------------------------------------------- */ -static void -DeleteExecStack( - ExecStack *esPtr) -{ - if (esPtr->markerPtr && !cachedInExit) { - Tcl_Panic("freeing an execStack which is still in use"); - } - - if (esPtr->prevPtr) { - esPtr->prevPtr->nextPtr = esPtr->nextPtr; - } - if (esPtr->nextPtr) { - esPtr->nextPtr->prevPtr = esPtr->prevPtr; - } - ckfree(esPtr); -} - void -TclDeleteExecEnv( - ExecEnv *eePtr) /* Execution environment to free. */ +TclDeleteExecEnv(eePtr) + ExecEnv *eePtr; /* Execution environment to free. */ { - ExecStack *esPtr = eePtr->execStackPtr, *tmpPtr; - - cachedInExit = TclInExit(); - - /* - * Delete all stacks in this exec env. - */ - - while (esPtr->nextPtr) { - esPtr = esPtr->nextPtr; - } - while (esPtr) { - tmpPtr = esPtr; - esPtr = tmpPtr->prevPtr; - DeleteExecStack(tmpPtr); - } - - TclDecrRefCount(eePtr->constants[0]); - TclDecrRefCount(eePtr->constants[1]); - if (eePtr->callbackPtr && !cachedInExit) { - Tcl_Panic("Deleting execEnv with pending TEOV callbacks!"); - } - if (eePtr->corPtr && !cachedInExit) { - Tcl_Panic("Deleting execEnv with existing coroutine"); + if (eePtr->stackPtr[-1] == (Tcl_Obj *) ((char *) 1)) { + ckfree((char *) (eePtr->stackPtr-1)); + } else { + panic("ERROR: freeing an execEnv whose stack is still in use.\n"); } - ckfree(eePtr); + TclDecrRefCount(eePtr->errorInfo); + TclDecrRefCount(eePtr->errorCode); + ckfree((char *) eePtr); } /* @@ -950,21 +596,21 @@ TclDeleteExecEnv( * * TclFinalizeExecution -- * - * Finalizes the execution environment setup so that it can be later - * reinitialized. + * 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. + * After this call, the next time TclCreateExecEnv will be called + * it will call InitByteCodeExecution. * *---------------------------------------------------------------------- */ void -TclFinalizeExecution(void) +TclFinalizeExecution() { Tcl_MutexLock(&execMutex); execInitialized = 0; @@ -973,336 +619,69 @@ TclFinalizeExecution(void) } /* - * Auxiliary code to insure that GrowEvaluationStack always returns correctly - * aligned memory. - * - * WALLOCALIGN represents the alignment reqs in words, just as TCL_ALLOCALIGN - * represents the reqs in bytes. This assumes that TCL_ALLOCALIGN is a - * multiple of the wordsize 'sizeof(Tcl_Obj *)'. - */ - -#define WALLOCALIGN \ - (TCL_ALLOCALIGN/sizeof(Tcl_Obj *)) - -/* - * OFFSET computes how many words have to be skipped until the next aligned - * word. Note that we are only interested in the low order bits of ptr, so - * that any possible information loss in PTR2INT is of no consequence. - */ - -static inline int -OFFSET( - void *ptr) -{ - int mask = TCL_ALLOCALIGN-1; - int base = PTR2INT(ptr) & mask; - return (TCL_ALLOCALIGN - base)/sizeof(Tcl_Obj *); -} - -/* - * Given a marker, compute where the following aligned memory starts. - */ - -#define MEMSTART(markerPtr) \ - ((markerPtr) + OFFSET(markerPtr)) - -/* *---------------------------------------------------------------------- * * GrowEvaluationStack -- * - * This procedure grows a Tcl evaluation stack stored in an ExecEnv, - * copying over the words since the last mark if so requested. A mark is - * set at the beginning of the new area when no copying is requested. + * This procedure grows a Tcl evaluation stack stored in an ExecEnv. * * Results: - * Returns a pointer to the first usable word in the (possibly) grown - * stack. + * None. * * Side effects: - * The size of the evaluation stack may be grown, a marker is set + * The size of the evaluation stack is doubled. * *---------------------------------------------------------------------- */ -static Tcl_Obj ** -GrowEvaluationStack( - ExecEnv *eePtr, /* Points to the ExecEnv with an evaluation - * stack to enlarge. */ - int growth, /* How much larger than the current used - * size. */ - int move) /* 1 if move words since last marker. */ -{ - ExecStack *esPtr = eePtr->execStackPtr, *oldPtr = NULL; - int newBytes, newElems, currElems; - int needed = growth - (esPtr->endPtr - esPtr->tosPtr); - Tcl_Obj **markerPtr = esPtr->markerPtr, **memStart; - int moveWords = 0; - - if (move) { - if (!markerPtr) { - Tcl_Panic("STACK: Reallocating with no previous alloc"); - } - if (needed <= 0) { - return MEMSTART(markerPtr); - } - } else { - Tcl_Obj **tmpMarkerPtr = esPtr->tosPtr + 1; - int offset = OFFSET(tmpMarkerPtr); - - if (needed + offset < 0) { - /* - * Put a marker pointing to the previous marker in this stack, and - * store it in esPtr as the current marker. Return a pointer to - * the start of aligned memory. - */ - - esPtr->markerPtr = tmpMarkerPtr; - memStart = tmpMarkerPtr + offset; - esPtr->tosPtr = memStart - 1; - *esPtr->markerPtr = (Tcl_Obj *) markerPtr; - return memStart; - } - } - - /* - * Reset move to hold the number of words to be moved to new stack (if - * any) and growth to hold the complete stack requirements: add one for - * the marker, (WALLOCALIGN-1) for the maximal possible offset. - */ - - if (move) { - moveWords = esPtr->tosPtr - MEMSTART(markerPtr) + 1; - } - needed = growth + moveWords + WALLOCALIGN; - - /* - * Check if there is enough room in the next stack (if there is one, it - * should be both empty and the last one!) - */ - - if (esPtr->nextPtr) { - oldPtr = esPtr; - esPtr = oldPtr->nextPtr; - currElems = esPtr->endPtr - &esPtr->stackWords[-1]; - if (esPtr->markerPtr || (esPtr->tosPtr != &esPtr->stackWords[-1])) { - Tcl_Panic("STACK: Stack after current is in use"); - } - if (esPtr->nextPtr) { - Tcl_Panic("STACK: Stack after current is not last"); - } - if (needed <= currElems) { - goto newStackReady; - } - DeleteExecStack(esPtr); - esPtr = oldPtr; - } else { - currElems = esPtr->endPtr - &esPtr->stackWords[-1]; - } - - /* - * We need to allocate a new stack! It needs to store 'growth' words, - * including the elements to be copied over and the new marker. - */ - - newElems = 2*currElems; - while (needed > newElems) { - newElems *= 2; - } - newBytes = sizeof(ExecStack) + (newElems-1) * sizeof(Tcl_Obj *); - - oldPtr = esPtr; - esPtr = ckalloc(newBytes); - - oldPtr->nextPtr = esPtr; - esPtr->prevPtr = oldPtr; - esPtr->nextPtr = NULL; - esPtr->endPtr = &esPtr->stackWords[newElems-1]; - - newStackReady: - eePtr->execStackPtr = esPtr; - - /* - * Store a NULL marker at the beginning of the stack, to indicate that - * this is the first marker in this stack and that rewinding to here - * should actually be a return to the previous stack. - */ - - esPtr->stackWords[0] = NULL; - esPtr->markerPtr = &esPtr->stackWords[0]; - memStart = MEMSTART(esPtr->markerPtr); - esPtr->tosPtr = memStart - 1; - - if (move) { - memcpy(memStart, MEMSTART(markerPtr), moveWords*sizeof(Tcl_Obj *)); - esPtr->tosPtr += moveWords; - oldPtr->markerPtr = (Tcl_Obj **) *markerPtr; - oldPtr->tosPtr = markerPtr-1; - } - - /* - * Free the old stack if it is now unused. - */ - - if (!oldPtr->markerPtr) { - DeleteExecStack(oldPtr); - } - - return memStart; -} - -/* - *-------------------------------------------------------------- - * - * TclStackAlloc, TclStackRealloc, TclStackFree -- - * - * Allocate memory from the execution stack; it has to be returned later - * with a call to TclStackFree. - * - * Results: - * A pointer to the first byte allocated, or panics if the allocation did - * not succeed. - * - * Side effects: - * The execution stack may be grown. - * - *-------------------------------------------------------------- - */ - -static Tcl_Obj ** -StackAllocWords( - Tcl_Interp *interp, - int numWords) +static void +GrowEvaluationStack(eePtr) + register ExecEnv *eePtr; /* Points to the ExecEnv with an evaluation + * stack to enlarge. */ { /* - * Note that GrowEvaluationStack sets a marker in the stack. This marker - * is read when rewinding, e.g., by TclStackFree. + * The current Tcl stack elements are stored from eePtr->stackPtr[0] + * to eePtr->stackPtr[eePtr->stackEnd] (inclusive). */ - Interp *iPtr = (Interp *) interp; - ExecEnv *eePtr = iPtr->execEnvPtr; - Tcl_Obj **resPtr = GrowEvaluationStack(eePtr, numWords, 0); - - eePtr->execStackPtr->tosPtr += numWords; - return resPtr; -} - -static Tcl_Obj ** -StackReallocWords( - Tcl_Interp *interp, - int numWords) -{ - Interp *iPtr = (Interp *) interp; - ExecEnv *eePtr = iPtr->execEnvPtr; - Tcl_Obj **resPtr = GrowEvaluationStack(eePtr, numWords, 1); - - eePtr->execStackPtr->tosPtr += numWords; - return resPtr; -} - -void -TclStackFree( - Tcl_Interp *interp, - void *freePtr) -{ - Interp *iPtr = (Interp *) interp; - ExecEnv *eePtr; - ExecStack *esPtr; - Tcl_Obj **markerPtr, *marker; - - if (iPtr == NULL || iPtr->execEnvPtr == NULL) { - Tcl_Free((char *) freePtr); - return; - } + int currElems = (eePtr->stackEnd + 1); + int newElems = 2*currElems; + int currBytes = currElems * sizeof(Tcl_Obj *); + int newBytes = 2*currBytes; + Tcl_Obj **newStackPtr = (Tcl_Obj **) ckalloc((unsigned) newBytes); + Tcl_Obj **oldStackPtr = eePtr->stackPtr; /* - * Rewind the stack to the previous marker position. The current marker, - * as set in the last call to GrowEvaluationStack, contains a pointer to - * the previous marker. + * We keep the stack reference count as a (char *), as that + * works nicely as a portable pointer-sized counter. */ - eePtr = iPtr->execEnvPtr; - esPtr = eePtr->execStackPtr; - markerPtr = esPtr->markerPtr; - marker = *markerPtr; - - if ((freePtr != NULL) && (MEMSTART(markerPtr) != (Tcl_Obj **)freePtr)) { - Tcl_Panic("TclStackFree: incorrect freePtr (%p != %p). Call out of sequence?", - freePtr, MEMSTART(markerPtr)); - } - - esPtr->tosPtr = markerPtr - 1; - esPtr->markerPtr = (Tcl_Obj **) marker; - if (marker) { - return; - } + char *refCount = (char *) oldStackPtr[-1]; /* - * Return to previous active stack. Note that repeated expansions or - * reallocs could have generated several unused intervening stacks: free - * them too. + * Copy the existing stack items to the new stack space, free the old + * storage if appropriate, and record the refCount of the new stack + * held by the environment. */ + + newStackPtr++; + memcpy((VOID *) newStackPtr, (VOID *) oldStackPtr, + (size_t) currBytes); - while (esPtr->nextPtr) { - esPtr = esPtr->nextPtr; - } - esPtr->tosPtr = &esPtr->stackWords[-1]; - while (esPtr->prevPtr) { - ExecStack *tmpPtr = esPtr->prevPtr; - if (tmpPtr->tosPtr == &tmpPtr->stackWords[-1]) { - DeleteExecStack(tmpPtr); - } else { - break; - } - } - if (esPtr->prevPtr) { - eePtr->execStackPtr = esPtr->prevPtr; + if (refCount == (char *) 1) { + ckfree((VOID *) (oldStackPtr-1)); } else { - eePtr->execStackPtr = esPtr; - } -} - -void * -TclStackAlloc( - Tcl_Interp *interp, - int numBytes) -{ - Interp *iPtr = (Interp *) interp; - int numWords = (numBytes + (sizeof(Tcl_Obj *) - 1))/sizeof(Tcl_Obj *); - - if (iPtr == NULL || iPtr->execEnvPtr == NULL) { - return (void *) Tcl_Alloc(numBytes); - } - - return (void *) StackAllocWords(interp, numWords); -} - -void * -TclStackRealloc( - Tcl_Interp *interp, - void *ptr, - int numBytes) -{ - Interp *iPtr = (Interp *) interp; - ExecEnv *eePtr; - ExecStack *esPtr; - Tcl_Obj **markerPtr; - int numWords; - - if (iPtr == NULL || iPtr->execEnvPtr == NULL) { - return (void *) Tcl_Realloc((char *) ptr, numBytes); - } - - eePtr = iPtr->execEnvPtr; - esPtr = eePtr->execStackPtr; - markerPtr = esPtr->markerPtr; - - if (MEMSTART(markerPtr) != (Tcl_Obj **)ptr) { - Tcl_Panic("TclStackRealloc: incorrect ptr. Call out of sequence?"); + /* + * Remove the reference corresponding to the + * environment pointer. + */ + + oldStackPtr[-1] = (Tcl_Obj *) (refCount-1); } - numWords = (numBytes + (sizeof(Tcl_Obj *) - 1))/sizeof(Tcl_Obj *); - return (void *) StackReallocWords(interp, numWords); + eePtr->stackPtr = newStackPtr; + eePtr->stackEnd = (newElems - 2); /* index of last usable item */ + newStackPtr[-1] = (Tcl_Obj *) ((char *) 1); } /* @@ -1313,212 +692,203 @@ TclStackRealloc( * Evaluate an expression in a Tcl_Obj. * * Results: - * A standard Tcl object result. If the result is other than TCL_OK, then - * the interpreter's result contains an error message. If the result is - * TCL_OK, then a pointer to the expression's result value object is - * stored in resultPtrPtr. In that case, the object's ref count is - * incremented to reflect the reference returned to the caller; the - * caller is then responsible for the resulting object and must, for - * example, decrement the ref count when it is finished with the object. + * A standard Tcl object result. If the result is other than TCL_OK, + * then the interpreter's result contains an error message. If the + * result is TCL_OK, then a pointer to the expression's result value + * object is stored in resultPtrPtr. In that case, the object's ref + * count is incremented to reflect the reference returned to the + * caller; the caller is then responsible for the resulting object + * and must, for example, decrement the ref count when it is finished + * with the object. * * Side effects: - * Any side effects caused by subcommands in the expression, if any. The - * interpreter result is not modified unless there is an error. + * Any side effects caused by subcommands in the expression, if any. + * The interpreter result is not modified unless there is an error. * *-------------------------------------------------------------- */ int -Tcl_ExprObj( - Tcl_Interp *interp, /* Context in which to evaluate the +Tcl_ExprObj(interp, objPtr, resultPtrPtr) + Tcl_Interp *interp; /* Context in which to evaluate the * expression. */ - register Tcl_Obj *objPtr, /* Points to Tcl object containing expression - * to evaluate. */ - Tcl_Obj **resultPtrPtr) /* Where the Tcl_Obj* that is the expression + register Tcl_Obj *objPtr; /* Points to Tcl object containing + * expression to evaluate. */ + Tcl_Obj **resultPtrPtr; /* Where the Tcl_Obj* that is the expression * result is stored if no errors occur. */ { - NRE_callback *rootPtr = TOP_CB(interp); - Tcl_Obj *resultPtr; - - TclNewObj(resultPtr); - TclNRAddCallback(interp, CopyCallback, resultPtrPtr, resultPtr, - NULL, NULL); - Tcl_NRExprObj(interp, objPtr, resultPtr); - return TclNRRunCallbacks(interp, TCL_OK, rootPtr); -} + Interp *iPtr = (Interp *) interp; + CompileEnv compEnv; /* Compilation environment structure + * allocated in frame. */ + LiteralTable *localTablePtr = &(compEnv.localLitTable); + register ByteCode *codePtr = NULL; + /* Tcl Internal type of bytecode. + * Initialized to avoid compiler warning. */ + AuxData *auxDataPtr; + LiteralEntry *entryPtr; + Tcl_Obj *saveObjPtr; + char *string; + int length, i, result; -static int -CopyCallback( - ClientData data[], - Tcl_Interp *interp, - int result) -{ - Tcl_Obj **resultPtrPtr = data[0]; - Tcl_Obj *resultPtr = data[1]; + /* + * First handle some common expressions specially. + */ - if (result == TCL_OK) { - *resultPtrPtr = resultPtr; - Tcl_IncrRefCount(resultPtr); - } else { - Tcl_DecrRefCount(resultPtr); + string = Tcl_GetStringFromObj(objPtr, &length); + if (length == 1) { + if (*string == '0') { + *resultPtrPtr = Tcl_NewLongObj(0); + Tcl_IncrRefCount(*resultPtrPtr); + return TCL_OK; + } else if (*string == '1') { + *resultPtrPtr = Tcl_NewLongObj(1); + Tcl_IncrRefCount(*resultPtrPtr); + return TCL_OK; + } + } else if ((length == 2) && (*string == '!')) { + if (*(string+1) == '0') { + *resultPtrPtr = Tcl_NewLongObj(1); + Tcl_IncrRefCount(*resultPtrPtr); + return TCL_OK; + } else if (*(string+1) == '1') { + *resultPtrPtr = Tcl_NewLongObj(0); + Tcl_IncrRefCount(*resultPtrPtr); + return TCL_OK; + } } - return result; -} - -/* - *-------------------------------------------------------------- - * - * Tcl_NRExprObj -- - * - * Request evaluation of the expression in a Tcl_Obj by the NR stack. - * - * Results: - * Returns TCL_OK. - * - * Side effects: - * Compiles objPtr as a Tcl expression and places callbacks on the - * NR stack to execute the bytecode and store the result in resultPtr. - * If bytecode execution raises an exception, nothing is written - * to resultPtr, and the exceptional return code flows up the NR - * stack. If the exception is TCL_ERROR, an error message is left - * in the interp result and the interp's return options dictionary - * holds additional error information too. Execution of the bytecode - * may have other side effects, depending on the expression. - * - *-------------------------------------------------------------- - */ - -int -Tcl_NRExprObj( - Tcl_Interp *interp, - Tcl_Obj *objPtr, - Tcl_Obj *resultPtr) -{ - ByteCode *codePtr; - - /* TODO: consider saving whole state? */ - Tcl_Obj *saveObjPtr = Tcl_GetObjResult(interp); + /* + * Compile and execute the expression after saving the interp's result. + */ + + saveObjPtr = Tcl_GetObjResult(interp); Tcl_IncrRefCount(saveObjPtr); - codePtr = CompileExprObj(interp, objPtr); - - /* TODO: Confirm reset not required? */ - /*Tcl_ResetResult(interp);*/ - Tcl_NRAddCallback(interp, ExprObjCallback, saveObjPtr, resultPtr, - NULL, NULL); - return TclNRExecuteByteCode(interp, codePtr); -} - -static int -ExprObjCallback( - ClientData data[], - Tcl_Interp *interp, - int result) -{ - Tcl_Obj *saveObjPtr = data[0]; - Tcl_Obj *resultPtr = data[1]; - - if (result == TCL_OK) { - TclSetDuplicateObj(resultPtr, Tcl_GetObjResult(interp)); - Tcl_SetObjResult(interp, saveObjPtr); - } - TclDecrRefCount(saveObjPtr); - return result; -} - -/* - *---------------------------------------------------------------------- - * - * CompileExprObj -- - * Compile a Tcl expression value into ByteCode. - * - * Results: - * A (ByteCode *) is returned pointing to the resulting ByteCode. - * The caller must manage its refCount and arrange for a call to - * TclCleanupByteCode() when the last reference disappears. - * - * Side effects: - * The Tcl_ObjType of objPtr is changed to the "bytecode" type, - * and the ByteCode is kept in the internal rep (along with context - * data for checking validity) for faster operations the next time - * CompileExprObj is called on the same value. - * - *---------------------------------------------------------------------- - */ - -static ByteCode * -CompileExprObj( - Tcl_Interp *interp, - Tcl_Obj *objPtr) -{ - Interp *iPtr = (Interp *) interp; - CompileEnv compEnv; /* Compilation environment structure allocated - * in frame. */ - register ByteCode *codePtr = NULL; - /* Tcl Internal type of bytecode. Initialized - * to avoid compiler warning. */ - /* * Get the expression ByteCode from the object. If it exists, make sure it * is valid in the current context. */ + if (objPtr->typePtr == &exprCodeType) { - Namespace *namespacePtr = iPtr->varFramePtr->nsPtr; + Namespace *namespacePtr = iPtr->varFramePtr ? + iPtr->varFramePtr->nsPtr : iPtr->globalNsPtr; - codePtr = objPtr->internalRep.otherValuePtr; + codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr; if (((Interp *) *codePtr->interpHandle != iPtr) - || (codePtr->compileEpoch != iPtr->compileEpoch) - || (codePtr->nsPtr != namespacePtr) - || (codePtr->nsEpoch != namespacePtr->resolverEpoch) - || (codePtr->localCachePtr != iPtr->varFramePtr->localCachePtr)) { - FreeExprCodeInternalRep(objPtr); + || (codePtr->compileEpoch != iPtr->compileEpoch) + || (codePtr->nsPtr != namespacePtr) + || (codePtr->nsEpoch != namespacePtr->resolverEpoch)) { + objPtr->typePtr->freeIntRepProc(objPtr); + objPtr->typePtr = (Tcl_ObjType *) NULL; } } if (objPtr->typePtr != &exprCodeType) { +#ifndef TCL_TIP280 + TclInitCompileEnv(interp, &compEnv, string, length); +#else + /* TIP #280 : No invoker (yet) - Expression compilation */ + TclInitCompileEnv(interp, &compEnv, string, length, NULL, 0); +#endif + result = TclCompileExpr(interp, string, length, &compEnv); + /* - * TIP #280: No invoker (yet) - Expression compilation. + * Free the compilation environment's literal table bucket array if + * it was dynamically allocated. */ - int length; - const char *string = TclGetStringFromObj(objPtr, &length); + if (localTablePtr->buckets != localTablePtr->staticBuckets) { + ckfree((char *) localTablePtr->buckets); + } + + if (result != TCL_OK) { + /* + * Compilation errors. Free storage allocated for compilation. + */ - TclInitCompileEnv(interp, &compEnv, string, length, NULL, 0); - TclCompileExpr(interp, string, length, &compEnv, 0); +#ifdef TCL_COMPILE_DEBUG + TclVerifyLocalLiteralTable(&compEnv); +#endif /*TCL_COMPILE_DEBUG*/ + entryPtr = compEnv.literalArrayPtr; + for (i = 0; i < compEnv.literalArrayNext; i++) { + TclReleaseLiteral(interp, entryPtr->objPtr); + entryPtr++; + } +#ifdef TCL_COMPILE_DEBUG + TclVerifyGlobalLiteralTable(iPtr); +#endif /*TCL_COMPILE_DEBUG*/ + + auxDataPtr = compEnv.auxDataArrayPtr; + for (i = 0; i < compEnv.auxDataArrayNext; i++) { + if (auxDataPtr->type->freeProc != NULL) { + auxDataPtr->type->freeProc(auxDataPtr->clientData); + } + auxDataPtr++; + } + TclFreeCompileEnv(&compEnv); + goto done; + } /* - * Successful compilation. If the expression yielded no instructions, - * push an zero object as the expression's result. + * Successful compilation. If the expression yielded no + * instructions, push an zero object as the expression's result. */ - + if (compEnv.codeNext == compEnv.codeStart) { - TclEmitPush(TclRegisterNewLiteral(&compEnv, "0", 1), - &compEnv); + TclEmitPush(TclRegisterLiteral(&compEnv, "0", 1, /*onHeap*/ 0), + &compEnv); } - + /* * Add a "done" instruction as the last instruction and change the - * object into a ByteCode object. Ownership of the literal objects and - * aux data items is given to the ByteCode object. + * object into a ByteCode object. Ownership of the literal objects + * and aux data items is given to the ByteCode object. */ + compEnv.numSrcBytes = iPtr->termOffset; TclEmitOpcode(INST_DONE, &compEnv); TclInitByteCodeObj(objPtr, &compEnv); objPtr->typePtr = &exprCodeType; TclFreeCompileEnv(&compEnv); - codePtr = objPtr->internalRep.otherValuePtr; - if (iPtr->varFramePtr->localCachePtr) { - codePtr->localCachePtr = iPtr->varFramePtr->localCachePtr; - codePtr->localCachePtr->refCount++; - } + codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr; #ifdef TCL_COMPILE_DEBUG if (tclTraceCompile == 2) { TclPrintByteCodeObj(interp, objPtr); - fflush(stdout); } #endif /* TCL_COMPILE_DEBUG */ } - return codePtr; + + Tcl_ResetResult(interp); + + /* + * Increment the code's ref count while it is being executed. If + * afterwards no references to it remain, free the code. + */ + + codePtr->refCount++; + result = TclExecuteByteCode(interp, codePtr); + codePtr->refCount--; + if (codePtr->refCount <= 0) { + TclCleanupByteCode(codePtr); + } + + /* + * If the expression evaluated successfully, store a pointer to its + * value object in resultPtrPtr then restore the old interpreter result. + * We increment the object's ref count to reflect the reference that we + * are returning to the caller. We also decrement the ref count of the + * interpreter's result object after calling Tcl_SetResult since we + * next store into that field directly. + */ + + if (result == TCL_OK) { + *resultPtrPtr = iPtr->objResultPtr; + Tcl_IncrRefCount(iPtr->objResultPtr); + + Tcl_SetObjResult(interp, saveObjPtr); + } +done: + TclDecrRefCount(saveObjPtr); + return result; } /* @@ -1527,17 +897,17 @@ CompileExprObj( * DupExprCodeInternalRep -- * * Part of the Tcl object type implementation for Tcl expression - * bytecode. We do not copy the bytecode intrep. Instead, we return - * without setting copyPtr->typePtr, so the copy is a plain string copy - * of the expression value, and if it is to be used as a compiled - * expression, it will just need a recompile. - * - * This makes sense, because with Tcl's copy-on-write practices, the - * usual (only?) time Tcl_DuplicateObj() will be called is when the copy - * is about to be modified, which would invalidate any copied bytecode - * anyway. The only reason it might make sense to copy the bytecode is if - * we had some modifying routines that operated directly on the intrep, - * like we do for lists and dicts. + * bytecode. We do not copy the bytecode intrep. Instead, we + * return without setting copyPtr->typePtr, so the copy is a plain + * string copy of the expression value, and if it is to be used + * as a compiled expression, it will just need a recompile. + * + * This makes sense, because with Tcl's copy-on-write practices, + * the usual (only?) time Tcl_DuplicateObj() will be called is + * when the copy is about to be modified, which would invalidate + * any copied bytecode anyway. The only reason it might make sense + * to copy the bytecode is if we had some modifying routines that + * operated directly on the intrep, like we do for lists and dicts. * * Results: * None. @@ -1562,15 +932,14 @@ DupExprCodeInternalRep( * FreeExprCodeInternalRep -- * * Part of the Tcl object type implementation for Tcl expression - * bytecode. Frees the storage allocated to hold the internal rep, unless - * ref counts indicate bytecode execution is still in progress. + * bytecode. Frees the storage allocated to hold the internal rep, + * unless ref counts indicate bytecode execution is still in progress. * * Results: * None. * * Side effects: - * May free allocated memory. Leaves objPtr untyped. - * + * May free allocated memory. Leaves objPtr untyped. *---------------------------------------------------------------------- */ @@ -1578,797 +947,447 @@ static void FreeExprCodeInternalRep( Tcl_Obj *objPtr) { - ByteCode *codePtr = objPtr->internalRep.otherValuePtr; + ByteCode *codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr; - objPtr->typePtr = NULL; - objPtr->internalRep.otherValuePtr = NULL; codePtr->refCount--; if (codePtr->refCount <= 0) { TclCleanupByteCode(codePtr); } + objPtr->typePtr = NULL; + objPtr->internalRep.otherValuePtr = NULL; } /* *---------------------------------------------------------------------- * - * TclCompileObj -- + * TclCompEvalObj -- * - * This procedure compiles the script contained in a Tcl_Obj. + * This procedure evaluates the script contained in a Tcl_Obj by + * first compiling it and then passing it to TclExecuteByteCode. * * Results: - * A pointer to the corresponding ByteCode, never NULL. + * 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: - * The object is shimmered to bytecode type. + * Almost certainly, depending on the ByteCode's instructions. * *---------------------------------------------------------------------- */ -ByteCode * -TclCompileObj( - Tcl_Interp *interp, - Tcl_Obj *objPtr, - const CmdFrame *invoker, - int word) +int +#ifndef TCL_TIP280 +TclCompEvalObj(interp, objPtr) +#else +TclCompEvalObj(interp, objPtr, invoker, word) +#endif + Tcl_Interp *interp; + Tcl_Obj *objPtr; +#ifdef TCL_TIP280 + CONST CmdFrame* invoker; /* Frame of the command doing the eval */ + int word; /* Index of the word which is in objPtr */ +#endif { register Interp *iPtr = (Interp *) interp; - register ByteCode *codePtr; /* Tcl Internal type of bytecode. */ - Namespace *namespacePtr = iPtr->varFramePtr->nsPtr; + register ByteCode* codePtr; /* Tcl Internal type of bytecode. */ + int oldCount = iPtr->cmdCount; /* Used to tell whether any commands + * at all were executed. */ + char *script; + int numSrcBytes; + int result; + Namespace *namespacePtr; + /* - * If the object is not already of tclByteCodeType, compile it (and reset - * the compilation flags in the interpreter; this should be done after any - * compilation). Otherwise, check that it is "fresh" enough. + * Check that the interpreter is ready to execute scripts */ - if (objPtr->typePtr == &tclByteCodeType) { - /* - * Make sure the Bytecode hasn't been invalidated by, e.g., someone - * redefining a command with a compile procedure (this might make the - * compiled code wrong). The object needs to be recompiled if it was - * compiled in/for a different interpreter, or for a different - * namespace, or for the same namespace but with different name - * resolution rules. Precompiled objects, however, are immutable and - * therefore they are not recompiled, even if the epoch has changed. - * - * To be pedantically correct, we should also check that the - * originating procPtr is the same as the current context procPtr - * (assuming one exists at all - none for global level). This code is - * #def'ed out because [info body] was changed to never return a - * bytecode type object, which should obviate us from the extra checks - * here. - */ + iPtr->numLevels++; + if (TclInterpReady(interp) == TCL_ERROR) { + iPtr->numLevels--; + return TCL_ERROR; + } - codePtr = objPtr->internalRep.otherValuePtr; - if (((Interp *) *codePtr->interpHandle != iPtr) - || (codePtr->compileEpoch != iPtr->compileEpoch) - || (codePtr->nsPtr != namespacePtr) - || (codePtr->nsEpoch != namespacePtr->resolverEpoch)) { - if (!(codePtr->flags & TCL_BYTECODE_PRECOMPILED)) { - goto recompileObj; - } - if ((Interp *) *codePtr->interpHandle != iPtr) { - Tcl_Panic("Tcl_EvalObj: compiled script jumped interps"); - } - codePtr->compileEpoch = iPtr->compileEpoch; - } + if (iPtr->varFramePtr != NULL) { + namespacePtr = iPtr->varFramePtr->nsPtr; + } else { + namespacePtr = iPtr->globalNsPtr; + } - /* - * Check that any compiled locals do refer to the current proc - * environment! If not, recompile. + /* + * If the object is not already of tclByteCodeType, compile it (and + * reset the compilation flags in the interpreter; this should be + * done after any compilation). + * Otherwise, check that it is "fresh" enough. + */ + + if (objPtr->typePtr != &tclByteCodeType) { + recompileObj: + iPtr->errorLine = 1; + +#ifdef TCL_TIP280 + /* TIP #280. Remember the invoker for a moment in the interpreter + * structures so that the byte code compiler can pick it up when + * initializing the compilation environment, i.e. the extended + * location information. */ - if (!(codePtr->flags & TCL_BYTECODE_PRECOMPILED) && - (codePtr->procPtr == NULL) && - (codePtr->localCachePtr != iPtr->varFramePtr->localCachePtr)){ - goto recompileObj; - } + iPtr->invokeCmdFramePtr = invoker; + iPtr->invokeWord = word; +#endif + result = tclByteCodeType.setFromAnyProc(interp, objPtr); +#ifdef TCL_TIP280 + iPtr->invokeCmdFramePtr = NULL; +#endif + if (result != TCL_OK) { + iPtr->numLevels--; + return result; + } + codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr; + } else { /* - * #280. - * Literal sharing fix. This part of the fix is not required by 8.4 - * nor 8.5, because they eval-direct any literals, so just saving the - * argument locations per command in bytecode is enough, embedded - * 'eval' commands, etc. get the correct information. - * - * But in 8.6 all the embedded script are compiled, and the resulting - * bytecode stored in the literal. Now the shared literal has bytecode - * with location data for _one_ particular location this literal is - * found at. If we get executed from a different location the bytecode - * has to be recompiled to get the correct locations. Not doing this - * will execute the saved bytecode with data for a different location, - * causing 'info frame' to point to the wrong place in the sources. - * - * Future optimizations ... - * (1) Save the location data (ExtCmdLoc) keyed by start line. In that - * case we recompile once per location of the literal, but not - * continously, because the moment we have all locations we do not - * need to recompile any longer. - * - * (2) Alternative: Do not recompile, tell the execution engine the - * offset between saved starting line and actual one. Then modify - * the users to adjust the locations they have by this offset. + * Make sure the Bytecode hasn't been invalidated by, e.g., someone + * redefining a command with a compile procedure (this might make the + * compiled code wrong). + * The object needs to be recompiled if it was compiled in/for a + * different interpreter, or for a different namespace, or for the + * same namespace but with different name resolution rules. + * Precompiled objects, however, are immutable and therefore + * they are not recompiled, even if the epoch has changed. * - * (3) Alternative 2: Do not fully recompile, adjust just the location - * information. + * To be pedantically correct, we should also check that the + * originating procPtr is the same as the current context procPtr + * (assuming one exists at all - none for global level). This + * code is #def'ed out because [info body] was changed to never + * return a bytecode type object, which should obviate us from + * the extra checks here. */ - - if (invoker == NULL) { - return codePtr; - } else { - Tcl_HashEntry *hePtr = - Tcl_FindHashEntry(iPtr->lineBCPtr, codePtr); - ExtCmdLoc *eclPtr; - CmdFrame *ctxCopyPtr; - int redo; - - if (!hePtr) { - return codePtr; - } - - eclPtr = Tcl_GetHashValue(hePtr); - redo = 0; - ctxCopyPtr = TclStackAlloc(interp, sizeof(CmdFrame)); - *ctxCopyPtr = *invoker; - - if (invoker->type == TCL_LOCATION_BC) { - /* - * Note: Type BC => ctx.data.eval.path is not used. - * ctx.data.tebc.codePtr used instead - */ - - TclGetSrcInfoForPc(ctxCopyPtr); - if (ctxCopyPtr->type == TCL_LOCATION_SOURCE) { - /* - * The reference made by 'TclGetSrcInfoForPc' is dead. - */ - - Tcl_DecrRefCount(ctxCopyPtr->data.eval.path); - ctxCopyPtr->data.eval.path = NULL; - } - } - - if (word < ctxCopyPtr->nline) { + codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr; + if (((Interp *) *codePtr->interpHandle != iPtr) + || (codePtr->compileEpoch != iPtr->compileEpoch) +#ifdef CHECK_PROC_ORIGINATION /* [Bug: 3412 Pedantic] */ + || (codePtr->procPtr != NULL && !(iPtr->varFramePtr && + iPtr->varFramePtr->procPtr == codePtr->procPtr)) +#endif + || (codePtr->nsPtr != namespacePtr) + || (codePtr->nsEpoch != namespacePtr->resolverEpoch)) { + if (codePtr->flags & TCL_BYTECODE_PRECOMPILED) { + if ((Interp *) *codePtr->interpHandle != iPtr) { + panic("Tcl_EvalObj: compiled script jumped interps"); + } + codePtr->compileEpoch = iPtr->compileEpoch; + } else { /* - * Note: We do not care if the line[word] is -1. This is a - * difference and requires a recompile (location changed from - * absolute to relative, literal is used fixed and through - * variable) - * - * Example: - * test info-32.0 using literal of info-24.8 - * (dict with ... vs set body ...). + * This byteCode is invalid: free it and recompile */ - - redo = ((eclPtr->type == TCL_LOCATION_SOURCE) - && (eclPtr->start != ctxCopyPtr->line[word])) - || ((eclPtr->type == TCL_LOCATION_BC) - && (ctxCopyPtr->type == TCL_LOCATION_SOURCE)); - } - - TclStackFree(interp, ctxCopyPtr); - if (!redo) { - return codePtr; + tclByteCodeType.freeIntRepProc(objPtr); + goto recompileObj; } } } - recompileObj: - iPtr->errorLine = 1; - /* - * TIP #280. Remember the invoker for a moment in the interpreter - * structures so that the byte code compiler can pick it up when - * initializing the compilation environment, i.e. the extended location - * information. + * Execute the commands. If the code was compiled from an empty string, + * don't bother executing the code. */ - iPtr->invokeCmdFramePtr = invoker; - iPtr->invokeWord = word; - TclSetByteCodeFromAny(interp, objPtr, NULL, NULL); - iPtr->invokeCmdFramePtr = NULL; - codePtr = objPtr->internalRep.otherValuePtr; - if (iPtr->varFramePtr->localCachePtr) { - codePtr->localCachePtr = iPtr->varFramePtr->localCachePtr; - codePtr->localCachePtr->refCount++; - } - return codePtr; -} - -/* - *---------------------------------------------------------------------- - * - * TclIncrObj -- - * - * Increment an integeral value in a Tcl_Obj by an integeral value held - * in another Tcl_Obj. Caller is responsible for making sure we can - * update the first object. - * - * Results: - * TCL_ERROR if either object is non-integer, and TCL_OK otherwise. On - * error, an error message is left in the interpreter (if it is not NULL, - * of course). - * - * Side effects: - * valuePtr gets the new incrmented value. - * - *---------------------------------------------------------------------- - */ - -int -TclIncrObj( - Tcl_Interp *interp, - Tcl_Obj *valuePtr, - Tcl_Obj *incrPtr) -{ - ClientData ptr1, ptr2; - int type1, type2; - mp_int value, incr; - - if (Tcl_IsShared(valuePtr)) { - Tcl_Panic("%s called with shared object", "TclIncrObj"); - } - - if (GetNumberFromObj(NULL, valuePtr, &ptr1, &type1) != TCL_OK) { + numSrcBytes = codePtr->numSrcBytes; + if ((numSrcBytes > 0) || (codePtr->flags & TCL_BYTECODE_PRECOMPILED)) { /* - * Produce error message (reparse?!) + * Increment the code's ref count while it is being executed. If + * afterwards no references to it remain, free the code. */ - - return TclGetIntFromObj(interp, valuePtr, &type1); - } - if (GetNumberFromObj(NULL, incrPtr, &ptr2, &type2) != TCL_OK) { - /* - * Produce error message (reparse?!) - */ - - TclGetIntFromObj(interp, incrPtr, &type1); - Tcl_AddErrorInfo(interp, "\n (reading increment)"); - return TCL_ERROR; - } - - if ((type1 == TCL_NUMBER_LONG) && (type2 == TCL_NUMBER_LONG)) { - long augend = *((const long *) ptr1); - long addend = *((const long *) ptr2); - long sum = augend + addend; - - /* - * Overflow when (augend and sum have different sign) and (augend and - * addend have the same sign). This is encapsulated in the Overflowing - * macro. - */ - - if (!Overflowing(augend, addend, sum)) { - TclSetLongObj(valuePtr, sum); - return TCL_OK; + + codePtr->refCount++; + result = TclExecuteByteCode(interp, codePtr); + codePtr->refCount--; + if (codePtr->refCount <= 0) { + TclCleanupByteCode(codePtr); } -#ifndef NO_WIDE_TYPE - { - Tcl_WideInt w1 = (Tcl_WideInt) augend; - Tcl_WideInt w2 = (Tcl_WideInt) addend; - - /* - * We know the sum value is outside the long range, so we use the - * macro form that doesn't range test again. - */ - - TclSetWideIntObj(valuePtr, w1 + w2); - return TCL_OK; - } -#endif - } - - if ((type1 == TCL_NUMBER_DOUBLE) || (type1 == TCL_NUMBER_NAN)) { - /* - * Produce error message (reparse?!) - */ - - return TclGetIntFromObj(interp, valuePtr, &type1); + } else { + result = TCL_OK; } - if ((type2 == TCL_NUMBER_DOUBLE) || (type2 == TCL_NUMBER_NAN)) { - /* - * Produce error message (reparse?!) - */ + iPtr->numLevels--; - TclGetIntFromObj(interp, incrPtr, &type1); - Tcl_AddErrorInfo(interp, "\n (reading increment)"); - return TCL_ERROR; - } -#ifndef NO_WIDE_TYPE - if ((type1 != TCL_NUMBER_BIG) && (type2 != TCL_NUMBER_BIG)) { - Tcl_WideInt w1, w2, sum; + /* + * If no commands at all were executed, check for asynchronous + * handlers so that they at least get one change to execute. + * This is needed to handle event loops written in Tcl with + * empty bodies. + */ - TclGetWideIntFromObj(NULL, valuePtr, &w1); - TclGetWideIntFromObj(NULL, incrPtr, &w2); - sum = w1 + w2; + if ((oldCount == iPtr->cmdCount) && Tcl_AsyncReady()) { + result = Tcl_AsyncInvoke(interp, result); + /* - * Check for overflow. + * If an error occurred, record information about what was being + * executed when the error occurred. */ - - if (!Overflowing(w1, w2, sum)) { - Tcl_SetWideIntObj(valuePtr, sum); - return TCL_OK; + + if ((result == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) { + script = Tcl_GetStringFromObj(objPtr, &numSrcBytes); + Tcl_LogCommandInfo(interp, script, script, numSrcBytes); } } -#endif - Tcl_TakeBignumFromObj(interp, valuePtr, &value); - Tcl_GetBignumFromObj(interp, incrPtr, &incr); - mp_add(&value, &incr, &value); - mp_clear(&incr); - Tcl_SetBignumObj(valuePtr, &value); - return TCL_OK; + /* + * Set the interpreter's termOffset member to the offset of the + * character just after the last one executed. We approximate the offset + * of the last character executed by using the number of characters + * compiled. + */ + + iPtr->termOffset = numSrcBytes; + iPtr->flags &= ~ERR_ALREADY_LOGGED; + + return result; } /* *---------------------------------------------------------------------- * - * TclNRExecuteByteCode -- + * TclExecuteByteCode -- * - * This procedure executes the instructions of a ByteCode structure. It - * returns when a "done" instruction is executed or an error occurs. + * 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. + * 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. * *---------------------------------------------------------------------- */ -#define bcFramePtr (&TD->cmdFrame) -#define initCatchTop ((ptrdiff_t *) (&TD->stack[-1])) -#define initTosPtr ((Tcl_Obj **) (initCatchTop+codePtr->maxExceptDepth)) -#define esPtr (iPtr->execEnvPtr->execStackPtr) - -int -TclNRExecuteByteCode( - Tcl_Interp *interp, /* Token for command interpreter. */ - ByteCode *codePtr) /* The bytecode sequence to interpret. */ + +static int +TclExecuteByteCode(interp, codePtr) + Tcl_Interp *interp; /* Token for command interpreter. */ + ByteCode *codePtr; /* The bytecode sequence to interpret. */ { Interp *iPtr = (Interp *) interp; - TEBCdata *TD; - int size = sizeof(TEBCdata) - 1 - + (codePtr->maxStackDepth + codePtr->maxExceptDepth) - * sizeof(void *); - int numWords = (size + sizeof(Tcl_Obj *) - 1) / sizeof(Tcl_Obj *); - - if (iPtr->execEnvPtr->rewind) { - return TCL_ERROR; - } - - codePtr->refCount++; - - /* - * Reserve the stack, setup the TEBCdataPtr (TD) and CallFrame - * - * The execution uses a unified stack: first a TEBCdata, immediately - * above it a CmdFrame, then the catch stack, then the execution stack. - * - * 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). Make sure the - * execution stack is large enough to execute this ByteCode. - */ - - TD = (TEBCdata *) GrowEvaluationStack(iPtr->execEnvPtr, numWords, 0); - esPtr->tosPtr = initTosPtr; - - TD->codePtr = codePtr; - TD->pc = codePtr->codeStart; - TD->catchTop = initCatchTop; - TD->cleanup = 0; - TD->auxObjList = NULL; - TD->checkInterp = 0; - - /* - * TIP #280: Initialize the frame. Do not push it yet: it will be pushed - * every time that we call out from this TD, popped when we return to it. - */ - - bcFramePtr->type = ((codePtr->flags & TCL_BYTECODE_PRECOMPILED) - ? TCL_LOCATION_PREBC : TCL_LOCATION_BC); - bcFramePtr->level = (iPtr->cmdFramePtr ? iPtr->cmdFramePtr->level+1 : 1); - bcFramePtr->numLevels = iPtr->numLevels; - bcFramePtr->framePtr = iPtr->framePtr; - bcFramePtr->nextPtr = iPtr->cmdFramePtr; - bcFramePtr->nline = 0; - bcFramePtr->line = NULL; - bcFramePtr->litarg = NULL; - bcFramePtr->data.tebc.codePtr = codePtr; - bcFramePtr->data.tebc.pc = NULL; - bcFramePtr->cmd.str.cmd = NULL; - bcFramePtr->cmd.str.len = 0; + ExecEnv *eePtr = iPtr->execEnvPtr; + /* Points to the execution environment. */ + register Tcl_Obj **stackPtr = eePtr->stackPtr; + /* Cached evaluation stack base pointer. */ + register int stackTop = eePtr->stackTop; + /* Cached top index of evaluation stack. */ + register unsigned char *pc = codePtr->codeStart; + /* The current program counter. */ + int opnd; /* Current instruction's operand byte(s). */ + 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 storeFlags; + Tcl_Obj *valuePtr, *value2Ptr, *objPtr; + char *bytes; + int length; + long i = 0; /* Init. avoids compiler warning. */ + Tcl_WideInt w; + register int cleanup; + Tcl_Obj *objResultPtr; + char *part1, *part2; + Var *varPtr, *arrayPtr; + CallFrame *varFramePtr = iPtr->varFramePtr; -#ifdef TCL_COMPILE_STATS - iPtr->stats.numExecutions++; +#ifdef TCL_TIP280 + /* TIP #280 : Structures for tracking lines */ + CmdFrame bcFrame; #endif - /* - * Push the callback for bytecode execution - */ - - TclNRAddCallback(interp, TEBCresume, TD, /*resume*/ INT2PTR(0), - NULL, NULL); - return TCL_OK; -} - -static int -TEBCresume( - ClientData data[], - Tcl_Interp *interp, - int result) -{ - /* - * Compiler cast directive - not a real variable. - * Interp *iPtr = (Interp *) interp; - */ -#define iPtr ((Interp *) interp) - - /* - * Check just the read-traced/write-traced bit of a variable. - */ - -#define ReadTraced(varPtr) ((varPtr)->flags & VAR_TRACED_READ) -#define WriteTraced(varPtr) ((varPtr)->flags & VAR_TRACED_WRITE) -#define UnsetTraced(varPtr) ((varPtr)->flags & VAR_TRACED_UNSET) - - /* - * Bottom of allocated stack holds the NR data - */ - - /* - * Constants: variables that do not change during the execution, used - * sporadically: no special need for speed. - */ - - int instructionCount = 0; /* Counter that is used to work out when to - * call Tcl_AsyncReady() */ - const char *curInstName; #ifdef TCL_COMPILE_DEBUG - int traceInstructions; /* Whether we are doing instruction-level - * tracing or not. */ + int traceInstructions = (tclTraceExec == 3); + char cmdNameBuf[21]; #endif - - Var *compiledLocals = iPtr->varFramePtr->compiledLocals; - Tcl_Obj **constants = &iPtr->execEnvPtr->constants[0]; - -#define LOCAL(i) (&compiledLocals[(i)]) -#define TCONST(i) (constants[(i)]) + char *curInstName = NULL; /* - * These macros are just meant to save some global variables that are not - * used too frequently + * 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. */ - TEBCdata *TD = data[0]; -#define auxObjList (TD->auxObjList) -#define catchTop (TD->catchTop) -#define codePtr (TD->codePtr) -#define checkInterp (TD->checkInterp) - /* Indicates when a check of interp readyness is - * necessary. Set by CACHE_STACK_INFO() */ - - /* - * Globals: variables that store state, must remain valid at all times. - */ - - Tcl_Obj **tosPtr; /* Cached pointer to top of evaluation - * stack. */ - const unsigned char *pc; /* The current program counter. */ - - /* - * Transfer variables - needed only between opcodes, but not while - * executing an instruction. - */ - - int cleanup = 0; - Tcl_Obj *objResultPtr; - - /* - * Locals - variables that are used within opcodes or bounded sections of - * the file (jumps between opcodes within a family). - * NOTE: These are now mostly defined locally where needed. - */ - - Tcl_Obj *objPtr, *valuePtr, *value2Ptr, *part1Ptr, *part2Ptr, *tmpPtr; - Tcl_Obj **objv; - int objc = 0; - int opnd, length, pcAdjustment; - Var *varPtr, *arrayPtr; -#ifdef TCL_COMPILE_DEBUG - char cmdNameBuf[21]; +#define STATIC_CATCH_STACK_SIZE 4 + int (catchStackStorage[STATIC_CATCH_STACK_SIZE]); + int *catchStackPtr = catchStackStorage; + int catchTop = -1; + +#ifdef TCL_TIP280 + /* TIP #280 : Initialize the frame. Do not push it yet. */ + + bcFrame.type = ((codePtr->flags & TCL_BYTECODE_PRECOMPILED) + ? TCL_LOCATION_PREBC + : TCL_LOCATION_BC); + bcFrame.level = (iPtr->cmdFramePtr == NULL ? + 1 : + iPtr->cmdFramePtr->level + 1); + bcFrame.framePtr = iPtr->framePtr; + bcFrame.nextPtr = iPtr->cmdFramePtr; + bcFrame.nline = 0; + bcFrame.line = NULL; + + bcFrame.data.tebc.codePtr = codePtr; + bcFrame.data.tebc.pc = NULL; + bcFrame.cmd.str.cmd = NULL; + bcFrame.cmd.str.len = 0; #endif #ifdef TCL_COMPILE_DEBUG - traceInstructions = (tclTraceExec == 3); -#endif - - TEBC_DATA_DIG(); - -#ifdef TCL_COMPILE_DEBUG - if (!data[1] && (tclTraceExec >= 2)) { + if (tclTraceExec >= 2) { PrintByteCodeInfo(codePtr); - fprintf(stdout, " Starting stack top=%d\n", (int) CURR_DEPTH); + fprintf(stdout, " Starting stack top=%d\n", eePtr->stackTop); fflush(stdout); } + opnd = 0; /* Init. avoids compiler warning. */ #endif - - if (data[1] /* resume from invocation */) { - if (iPtr->execEnvPtr->rewind) { - result = TCL_ERROR; - } - NRE_ASSERT(iPtr->cmdFramePtr == bcFramePtr); - iPtr->cmdFramePtr = bcFramePtr->nextPtr; - if (iPtr->flags & INTERP_DEBUG_FRAME) { - TclArgumentBCRelease((Tcl_Interp *) iPtr, bcFramePtr); - } - if (codePtr->flags & TCL_BYTECODE_RECOMPILE) { - iPtr->flags |= ERR_ALREADY_LOGGED; - codePtr->flags &= ~TCL_BYTECODE_RECOMPILE; - } - - CACHE_STACK_INFO(); - if (result == TCL_OK) { -#ifndef TCL_COMPILE_DEBUG - if (*pc == INST_POP) { - NEXT_INST_V(1, cleanup, 0); - } + +#ifdef TCL_COMPILE_STATS + iPtr->stats.numExecutions++; #endif - /* - * Push the call's object result and continue execution with the - * next instruction. - */ - - TRACE_WITH_OBJ(("%u => ... after \"%.20s\": TCL_OK, result=", - objc, cmdNameBuf), Tcl_GetObjResult(interp)); - - objResultPtr = Tcl_GetObjResult(interp); - - /* - * Reset the interp's result to avoid possible duplications of - * large objects [Bug 781585]. We do not call Tcl_ResetResult to - * avoid any side effects caused by the resetting of errorInfo and - * errorCode [Bug 804681], which are not needed here. We chose - * instead to manipulate the interp's object result directly. - * - * Note that the result object is now in objResultPtr, it keeps - * the refCount it had in its role of iPtr->objResultPtr. - */ - TclNewObj(objPtr); - Tcl_IncrRefCount(objPtr); - iPtr->objResultPtr = objPtr; - NEXT_INST_V(0, cleanup, -1); - } + /* + * 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. + */ - /* - * Result not TCL_OK: fall through - */ + if (codePtr->maxExceptDepth > STATIC_CATCH_STACK_SIZE) { + catchStackPtr = (int *) + ckalloc(codePtr->maxExceptDepth * sizeof(int)); } - if (iPtr->execEnvPtr->rewind) { - result = TCL_ERROR; - goto abnormalReturn; - } + /* + * Make sure the stack has enough room to execute this ByteCode. + */ - if (result != TCL_OK) { - pc--; - goto processExceptionReturn; + while ((stackTop + codePtr->maxStackDepth) > eePtr->stackEnd) { + GrowEvaluationStack(eePtr); + stackPtr = eePtr->stackPtr; } /* - * Loop executing instructions until a "done" instruction, a TCL_RETURN, - * or some error. + * Loop executing instructions until a "done" instruction, a + * TCL_RETURN, or some error. */ goto cleanup0; + /* - * Targets for standard instruction endings; unrolled for speed in the - * most frequent cases (instructions that consume up to two stack - * elements). + * Targets for standard instruction endings; unrolled + * for speed in the most frequent cases (instructions that + * consume up to two stack elements). * - * This used to be a "for(;;)" loop, with each instruction doing its own - * cleanup. + * This used to be a "for(;;)" loop, with each instruction doing + * its own cleanup. */ - - cleanupV_pushObjResultPtr: + + cleanupV_pushObjResultPtr: switch (cleanup) { - case 0: - *(++tosPtr) = (objResultPtr); - goto cleanup0; - default: - cleanup -= 2; - while (cleanup--) { - objPtr = POP_OBJECT(); - TclDecrRefCount(objPtr); - } - case 2: - cleanup2_pushObjResultPtr: - objPtr = POP_OBJECT(); - TclDecrRefCount(objPtr); - case 1: - cleanup1_pushObjResultPtr: - objPtr = OBJ_AT_TOS; - TclDecrRefCount(objPtr); + case 0: + stackPtr[++stackTop] = (objResultPtr); + goto cleanup0; + default: + cleanup -= 2; + while (cleanup--) { + valuePtr = POP_OBJECT(); + TclDecrRefCount(valuePtr); + } + case 2: + cleanup2_pushObjResultPtr: + valuePtr = POP_OBJECT(); + TclDecrRefCount(valuePtr); + case 1: + cleanup1_pushObjResultPtr: + valuePtr = stackPtr[stackTop]; + TclDecrRefCount(valuePtr); } - OBJ_AT_TOS = objResultPtr; + stackPtr[stackTop] = objResultPtr; goto cleanup0; - - cleanupV: + + cleanupV: switch (cleanup) { - default: - cleanup -= 2; - while (cleanup--) { - objPtr = POP_OBJECT(); - TclDecrRefCount(objPtr); - } - case 2: - cleanup2: - objPtr = POP_OBJECT(); - TclDecrRefCount(objPtr); - case 1: - cleanup1: - objPtr = POP_OBJECT(); - TclDecrRefCount(objPtr); - case 0: - /* - * We really want to do nothing now, but this is needed for some - * compilers (SunPro CC). - */ - - break; + default: + cleanup -= 2; + while (cleanup--) { + valuePtr = POP_OBJECT(); + TclDecrRefCount(valuePtr); + } + case 2: + cleanup2: + valuePtr = POP_OBJECT(); + TclDecrRefCount(valuePtr); + case 1: + cleanup1: + valuePtr = POP_OBJECT(); + TclDecrRefCount(valuePtr); + case 0: + /* + * We really want to do nothing now, but this is needed + * for some compilers (SunPro CC) + */ + break; } - cleanup0: + cleanup0: + #ifdef TCL_COMPILE_DEBUG - /* - * Skip the stack depth check if an expansion is in progress. - */ - - ValidatePcAndStackTop(codePtr, pc, CURR_DEPTH, 0, - /*checkStack*/ auxObjList == NULL); + ValidatePcAndStackTop(codePtr, pc, stackTop, initStackTop); if (traceInstructions) { - fprintf(stdout, "%2d: %2d ", iPtr->numLevels, (int) CURR_DEPTH); + fprintf(stdout, "%2d: %2d ", iPtr->numLevels, stackTop); TclPrintInstruction(codePtr, pc); fflush(stdout); } #endif /* TCL_COMPILE_DEBUG */ - -#ifdef TCL_COMPILE_STATS + +#ifdef TCL_COMPILE_STATS iPtr->stats.instructionCount[*pc]++; #endif - /* - * Check for asynchronous handlers [Bug 746722]; we do the check every - * ASYNC_CHECK_COUNT_MASK instruction, of the form (2**n-1). - */ - - if ((instructionCount++ & ASYNC_CHECK_COUNT_MASK) == 0) { - DECACHE_STACK_INFO(); - if (TclAsyncReady(iPtr)) { - result = Tcl_AsyncInvoke(interp, result); - if (result == TCL_ERROR) { - CACHE_STACK_INFO(); - goto gotError; - } - } - - if (TclCanceled(iPtr)) { - if (Tcl_Canceled(interp, TCL_LEAVE_ERR_MSG) == TCL_ERROR) { - CACHE_STACK_INFO(); - goto gotError; - } - } - - if (TclLimitReady(iPtr->limit)) { - if (Tcl_LimitCheck(interp) == TCL_ERROR) { - CACHE_STACK_INFO(); - goto gotError; - } - } - CACHE_STACK_INFO(); - } - - TCL_DTRACE_INST_NEXT(); - - /* - * These two instructions account for 26% of all instructions (according - * to measurements on tclbench by Ben Vitale - * [http://www.cs.toronto.edu/syslab/pubs/tcl2005-vitale-zaleski.pdf] - * Resolving them before the switch reduces the cost of branch - * mispredictions, seems to improve runtime by 5% to 15%, and (amazingly!) - * reduces total obj size. - */ - - if (*pc == INST_LOAD_SCALAR1) { - goto instLoadScalar1; - } else if (*pc == INST_PUSH1) { - goto instPush1Peephole; - } + TCL_DTRACE_INST_NEXT(); switch (*pc) { - case INST_SYNTAX: - case INST_RETURN_IMM: { - int code = TclGetInt4AtPtr(pc+1); - int level = TclGetUInt4AtPtr(pc+5); - - /* - * OBJ_AT_TOS is returnOpts, OBJ_UNDER_TOS is resultObjPtr. - */ - - TRACE(("%u %u => ", code, level)); - result = TclProcessReturn(interp, code, level, OBJ_AT_TOS); - if (result == TCL_OK) { - TRACE_APPEND(("continuing to next instruction (result=\"%.30s\")", - O2S(objResultPtr))); - NEXT_INST_F(9, 1, 0); - } - Tcl_SetObjResult(interp, OBJ_UNDER_TOS); - if (*pc == INST_SYNTAX) { - iPtr->flags &= ~ERR_ALREADY_LOGGED; - } - cleanup = 2; - goto processExceptionReturn; - } - - case INST_RETURN_STK: - TRACE(("=> ")); - objResultPtr = POP_OBJECT(); - result = Tcl_SetReturnOptions(interp, OBJ_AT_TOS); - Tcl_DecrRefCount(OBJ_AT_TOS); - OBJ_AT_TOS = objResultPtr; - if (result == TCL_OK) { - TRACE_APPEND(("continuing to next instruction (result=\"%.30s\")", - O2S(objResultPtr))); - NEXT_INST_F(1, 0, 0); - } - Tcl_SetObjResult(interp, objResultPtr); - cleanup = 1; - goto processExceptionReturn; - case INST_DONE: - if (tosPtr > initTosPtr) { - /* - * Set the interpreter's object result to point to the topmost - * object from the stack, and check for a possible [catch]. The - * stackTop's level and refCount will be handled by "processCatch" - * or "abnormalReturn". - */ - - Tcl_SetObjResult(interp, OBJ_AT_TOS); -#ifdef TCL_COMPILE_DEBUG - TRACE_WITH_OBJ(("=> return code=%d, result=", result), - iPtr->objResultPtr); - if (traceInstructions) { - fprintf(stdout, "\n"); - } -#endif - goto checkForCatch; + if (stackTop <= initStackTop) { + stackTop--; + goto abnormalReturn; } - (void) POP_OBJECT(); - goto abnormalReturn; - - case INST_PUSH1: - instPush1Peephole: - PUSH_OBJECT(codePtr->objArrayPtr[TclGetUInt1AtPtr(pc+1)]); - TRACE_WITH_OBJ(("%u => ", TclGetInt1AtPtr(pc+1)), OBJ_AT_TOS); - pc += 2; -#if !TCL_COMPILE_DEBUG + /* - * Runtime peephole optimisation: check if we are pushing again. + * Set the interpreter's object result to point to the + * topmost object from the stack, and check for a possible + * [catch]. The stackTop's level and refCount will be handled + * by "processCatch" or "abnormalReturn". */ - if (*pc == INST_PUSH1) { - TCL_DTRACE_INST_NEXT(); - goto instPush1Peephole; + valuePtr = stackPtr[stackTop]; + Tcl_SetObjResult(interp, valuePtr); +#ifdef TCL_COMPILE_DEBUG + TRACE_WITH_OBJ(("=> return code=%d, result=", result), + iPtr->objResultPtr); + if (traceInstructions) { + fprintf(stdout, "\n"); } #endif - NEXT_INST_F(0, 0, 0); + goto checkForCatch; + + case INST_PUSH1: + objResultPtr = codePtr->objArrayPtr[TclGetUInt1AtPtr(pc+1)]; + TRACE_WITH_OBJ(("%u => ", TclGetInt1AtPtr(pc+1)), objResultPtr); + NEXT_INST_F(2, 0, 1); case INST_PUSH4: objResultPtr = codePtr->objArrayPtr[TclGetUInt4AtPtr(pc+1)]; @@ -2376,528 +1395,343 @@ TEBCresume( NEXT_INST_F(5, 0, 1); case INST_POP: - TRACE_WITH_OBJ(("=> discarding "), OBJ_AT_TOS); - objPtr = POP_OBJECT(); - TclDecrRefCount(objPtr); - - /* - * Runtime peephole optimisation: an INST_POP is scheduled at the end - * of most commands. If the next instruction is an INST_START_CMD, - * fall through to it. - */ - - pc++; -#if !TCL_COMPILE_DEBUG - if (*pc == INST_START_CMD) { - TCL_DTRACE_INST_NEXT(); - goto instStartCmdPeephole; - } -#endif - NEXT_INST_F(0, 0, 0); - - case INST_START_CMD: -#if !TCL_COMPILE_DEBUG - instStartCmdPeephole: -#endif - /* - * Remark that if the interpreter is marked for deletion its - * compileEpoch is modified, so that the epoch check also verifies - * that the interp is not deleted. If no outside call has been made - * since the last check, it is safe to omit the check. - */ - - iPtr->cmdCount += TclGetUInt4AtPtr(pc+5); - if (!checkInterp) { - goto instStartCmdOK; - } else if (((codePtr->compileEpoch == iPtr->compileEpoch) - && (codePtr->nsEpoch == iPtr->varFramePtr->nsPtr->resolverEpoch)) - || (codePtr->flags & TCL_BYTECODE_PRECOMPILED)) { - checkInterp = 0; - instStartCmdOK: - NEXT_INST_F(9, 0, 0); - } else { - const char *bytes; - - length = 0; - - /* - * We used to switch to direct eval; for NRE-awareness we now - * compile and eval the command so that this evaluation does not - * add a new TEBC instance. [Bug 2910748] - */ - - if (TclInterpReady(interp) == TCL_ERROR) { - goto gotError; - } - - codePtr->flags |= TCL_BYTECODE_RECOMPILE; - bytes = GetSrcInfoForPc(pc, codePtr, &length, NULL); - opnd = TclGetUInt4AtPtr(pc+1); - pc += (opnd-1); - PUSH_OBJECT(Tcl_NewStringObj(bytes, length)); - goto instEvalStk; - } - - case INST_NOP: - pc += 1; - goto cleanup0; - + TRACE_WITH_OBJ(("=> discarding "), stackPtr[stackTop]); + valuePtr = POP_OBJECT(); + TclDecrRefCount(valuePtr); + NEXT_INST_F(1, 0, 0); + case INST_DUP: - objResultPtr = OBJ_AT_TOS; + objResultPtr = stackPtr[stackTop]; TRACE_WITH_OBJ(("=> "), objResultPtr); NEXT_INST_F(1, 0, 1); case INST_OVER: - opnd = TclGetUInt4AtPtr(pc+1); - objResultPtr = OBJ_AT_DEPTH(opnd); + opnd = TclGetUInt4AtPtr( pc+1 ); + objResultPtr = stackPtr[ stackTop - opnd ]; TRACE_WITH_OBJ(("=> "), objResultPtr); NEXT_INST_F(5, 0, 1); - case INST_REVERSE: { - Tcl_Obj **a, **b; - - opnd = TclGetUInt4AtPtr(pc+1); - a = tosPtr-(opnd-1); - b = tosPtr; - while (a<b) { - tmpPtr = *a; - *a = *b; - *b = tmpPtr; - a++; b--; - } - NEXT_INST_F(5, 0, 0); - } - - case INST_CONCAT1: { - int appendLen = 0; - char *bytes, *p; - Tcl_Obj **currPtr; - int onlyb = 1; - + case INST_CONCAT1: opnd = TclGetUInt1AtPtr(pc+1); + { + int totalLen = 0; + + /* + * Peephole optimisation for appending an empty string. + * This enables replacing 'K $x [set x{}]' by '$x[set x{}]' + * for fastest execution. Avoid doing the optimisation for wide + * ints - a case where equal strings may refer to different values + * (see [Bug 1251791]). + */ - /* - * Detect only-bytearray-or-null case. - */ - - for (currPtr=&OBJ_AT_DEPTH(opnd-1); currPtr<=&OBJ_AT_TOS; currPtr++) { - if (((*currPtr)->typePtr != &tclByteArrayType) - && ((*currPtr)->bytes != tclEmptyStringRep)) { - onlyb = 0; - break; - } else if (((*currPtr)->typePtr == &tclByteArrayType) && - ((*currPtr)->bytes != NULL)) { - onlyb = 0; - break; - } - } - - /* - * Compute the length to be appended. - */ - - if (onlyb) { - for (currPtr = &OBJ_AT_DEPTH(opnd-2); - appendLen >= 0 && currPtr <= &OBJ_AT_TOS; currPtr++) { - if ((*currPtr)->bytes != tclEmptyStringRep) { - Tcl_GetByteArrayFromObj(*currPtr, &length); - appendLen += length; - } - } - } else { - for (currPtr = &OBJ_AT_DEPTH(opnd-2); - appendLen >= 0 && currPtr <= &OBJ_AT_TOS; currPtr++) { - bytes = TclGetStringFromObj(*currPtr, &length); - if (bytes != NULL) { - appendLen += length; + if ((opnd == 2) && (stackPtr[stackTop-1]->typePtr != &tclWideIntType)) { + Tcl_GetStringFromObj(stackPtr[stackTop], &length); + if (length == 0) { + /* Just drop the top item from the stack */ + NEXT_INST_F(2, 1, 0); } } - } - - if (appendLen < 0) { - /* TODO: convert panic to error ? */ - Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); - } - - /* - * If nothing is to be appended, just return the first object by - * dropping all the others from the stack; this saves both the - * computation and copy of the string rep of the first object, - * enabling the fast '$x[set x {}]' idiom for 'K $x [set x {}]'. - */ - - if (appendLen == 0) { - TRACE_WITH_OBJ(("%u => ", opnd), objResultPtr); - NEXT_INST_V(2, (opnd-1), 0); - } - - /* - * If the first object is shared, we need a new obj for the result; - * otherwise, we can reuse the first object. In any case, make sure it - * has enough room to accomodate all the concatenated bytes. Note that - * if it is unshared its bytes are copied by ckrealloc, so that we set - * the loop parameters to avoid copying them again: p points to the - * end of the already copied bytes, currPtr to the second object. - */ - - objResultPtr = OBJ_AT_DEPTH(opnd-1); - if (!onlyb) { - bytes = TclGetStringFromObj(objResultPtr, &length); - if (length + appendLen < 0) { - /* TODO: convert panic to error ? */ - Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", - INT_MAX); - } -#if !TCL_COMPILE_DEBUG - if (bytes != tclEmptyStringRep && !Tcl_IsShared(objResultPtr)) { - TclFreeIntRep(objResultPtr); - objResultPtr->bytes = ckrealloc(bytes, length+appendLen+1); - objResultPtr->length = length + appendLen; - p = TclGetString(objResultPtr) + length; - currPtr = &OBJ_AT_DEPTH(opnd - 2); - } else -#endif - { - p = ckalloc(length + appendLen + 1); - TclNewObj(objResultPtr); - objResultPtr->bytes = p; - objResultPtr->length = length + appendLen; - currPtr = &OBJ_AT_DEPTH(opnd - 1); - } /* - * Append the remaining characters. + * 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 (; currPtr <= &OBJ_AT_TOS; currPtr++) { - bytes = TclGetStringFromObj(*currPtr, &length); + for (i = (stackTop - (opnd-1)); + totalLen >= 0 && i <= stackTop; i++) { + bytes = Tcl_GetStringFromObj(stackPtr[i], &length); if (bytes != NULL) { - memcpy(p, bytes, (size_t) length); - p += length; + totalLen += length; } } - *p = '\0'; - } else { - bytes = (char *) Tcl_GetByteArrayFromObj(objResultPtr, &length); - if (length + appendLen < 0) { - /* TODO: convert panic to error ? */ + + if (totalLen < 0) { Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); } -#if !TCL_COMPILE_DEBUG - if (!Tcl_IsShared(objResultPtr)) { - bytes = (char *) Tcl_SetByteArrayLength(objResultPtr, - length + appendLen); - p = bytes + length; - currPtr = &OBJ_AT_DEPTH(opnd - 2); - } else -#endif - { - TclNewObj(objResultPtr); - bytes = (char *) Tcl_SetByteArrayLength(objResultPtr, - length + appendLen); - p = bytes; - currPtr = &OBJ_AT_DEPTH(opnd - 1); - } /* - * Append the remaining characters. + * Initialize the new append string object by appending the + * strings of the opnd stack objects. Also pop the objects. */ - for (; currPtr <= &OBJ_AT_TOS; currPtr++) { - if ((*currPtr)->bytes != tclEmptyStringRep) { - bytes = (char *) Tcl_GetByteArrayFromObj(*currPtr,&length); - memcpy(p, bytes, (size_t) length); - p += length; + TclNewObj(objResultPtr); + if (totalLen > 0) { + char *p = (char *) ckalloc((unsigned) (totalLen + 1)); + objResultPtr->bytes = p; + objResultPtr->length = totalLen; + for (i = (stackTop - (opnd-1)); i <= stackTop; i++) { + valuePtr = stackPtr[i]; + bytes = Tcl_GetStringFromObj(valuePtr, &length); + if (bytes != NULL) { + memcpy((VOID *) p, (VOID *) bytes, + (size_t) length); + p += length; + } } + *p = '\0'; } + + TRACE_WITH_OBJ(("%u => ", opnd), objResultPtr); + NEXT_INST_V(2, opnd, 1); } + + case INST_INVOKE_STK4: + opnd = TclGetUInt4AtPtr(pc+1); + pcAdjustment = 5; + goto doInvocation; - TRACE_WITH_OBJ(("%u => ", opnd), objResultPtr); - NEXT_INST_V(2, opnd, 1); - } - - case INST_EXPAND_START: - /* - * Push an element to the auxObjList. This records the current - * stack depth - i.e., the point in the stack where the expanded - * command starts. - * - * Use a Tcl_Obj as linked list element; slight mem waste, but faster - * allocation than ckalloc. This also abuses the Tcl_Obj structure, as - * we do not define a special tclObjType for it. It is not dangerous - * as the obj is never passed anywhere, so that all manipulations are - * performed here and in INST_INVOKE_EXPANDED (in case of an expansion - * error, also in INST_EXPAND_STKTOP). - */ - - TclNewObj(objPtr); - objPtr->internalRep.ptrAndLongRep.value = CURR_DEPTH; - PUSH_TAUX_OBJ(objPtr); - NEXT_INST_F(1, 0, 0); - - case INST_EXPAND_STKTOP: { - int i; - ptrdiff_t moved; - - /* - * Make sure that the element at stackTop is a list; if not, just - * leave with an error. Note that the element from the expand list - * will be removed at checkForCatch. - */ - - objPtr = OBJ_AT_TOS; - if (TclListObjGetElements(interp, objPtr, &objc, &objv) != TCL_OK) { - TRACE_WITH_OBJ(("%.30s => ERROR: ", O2S(objPtr)), - Tcl_GetObjResult(interp)); - goto gotError; - } - (void) POP_OBJECT(); - - /* - * Make sure there is enough room in the stack to expand this list - * *and* process the rest of the command (at least up to the next - * argument expansion or command end). The operand is the current - * stack depth, as seen by the compiler. - */ + case INST_INVOKE_STK1: + opnd = TclGetUInt1AtPtr(pc+1); + pcAdjustment = 2; + + doInvocation: + { + int objc = opnd; /* The number of arguments. */ + Tcl_Obj **objv; /* The array of argument objects. */ - length = objc + (codePtr->maxStackDepth - TclGetInt4AtPtr(pc+1)); - DECACHE_STACK_INFO(); - moved = GrowEvaluationStack(iPtr->execEnvPtr, length, 1) - - (Tcl_Obj **) TD; - if (moved) { /* - * Change the global data to point to the new stack: move the - * TEBCdataPtr TD, recompute the position of every other - * stack-allocated parameter, update the stack pointers. + * We keep the stack reference count as a (char *), as that + * works nicely as a portable pointer-sized counter. */ - esPtr = iPtr->execEnvPtr->execStackPtr; - TD = (TEBCdata *) (((Tcl_Obj **)TD) + moved); + char **preservedStackRefCountPtr; + + /* + * Reference to memory block containing + * objv array (must be kept live throughout + * trace and command invokations.) + */ - catchTop += moved; - tosPtr += moved; - } + objv = &(stackPtr[stackTop - (objc-1)]); - /* - * Expand the list at stacktop onto the stack; free the list. Knowing - * that it has a freeIntRepProc we use Tcl_DecrRefCount(). - */ +#ifdef TCL_COMPILE_DEBUG + if (tclTraceExec >= 2) { + if (traceInstructions) { + strncpy(cmdNameBuf, TclGetString(objv[0]), 20); + TRACE(("%u => call ", objc)); + } else { + fprintf(stdout, "%d: (%u) invoking ", + iPtr->numLevels, + (unsigned int)(pc - codePtr->codeStart)); + } + for (i = 0; i < objc; i++) { + TclPrintObject(stdout, objv[i], 15); + fprintf(stdout, " "); + } + fprintf(stdout, "\n"); + fflush(stdout); + } +#endif /*TCL_COMPILE_DEBUG*/ - for (i = 0; i < objc; i++) { - PUSH_OBJECT(objv[i]); - } + /* + * If trace procedures will be called, we need a + * command string to pass to TclEvalObjvInternal; note + * that a copy of the string will be made there to + * include the ending \0. + */ - Tcl_DecrRefCount(objPtr); - NEXT_INST_F(5, 0, 0); - } + bytes = NULL; + length = 0; + if (iPtr->tracePtr != NULL) { + Trace *tracePtr, *nextTracePtr; + + for (tracePtr = iPtr->tracePtr; tracePtr != NULL; + tracePtr = nextTracePtr) { + nextTracePtr = tracePtr->nextPtr; + if (tracePtr->level == 0 || + iPtr->numLevels <= tracePtr->level) { + /* + * Traces will be called: get command string + */ - case INST_EXPR_STK: { - ByteCode *newCodePtr; + bytes = GetSrcInfoForPc(pc, codePtr, &length); + break; + } + } + } else { + Command *cmdPtr; + cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, objv[0]); + if ((cmdPtr != NULL) && (cmdPtr->flags & CMD_HAS_EXEC_TRACES)) { + bytes = GetSrcInfoForPc(pc, codePtr, &length); + } + } - bcFramePtr->data.tebc.pc = (char *) pc; - iPtr->cmdFramePtr = bcFramePtr; - DECACHE_STACK_INFO(); - newCodePtr = CompileExprObj(interp, OBJ_AT_TOS); - CACHE_STACK_INFO(); - cleanup = 1; - pc++; - TEBC_YIELD(); - return TclNRExecuteByteCode(interp, newCodePtr); - } + /* + * A reference to part of the stack vector itself + * escapes our control: increase its refCount + * to stop it from being deallocated by a recursive + * call to ourselves. The extra variable is needed + * because all others are liable to change due to the + * trace procedures. + */ - /* - * INVOCATION BLOCK - */ + preservedStackRefCountPtr = (char **) (stackPtr-1); + ++*preservedStackRefCountPtr; - instEvalStk: - case INST_EVAL_STK: - bcFramePtr->data.tebc.pc = (char *) pc; - iPtr->cmdFramePtr = bcFramePtr; + /* + * Finally, let TclEvalObjvInternal handle the command. + * + * TIP #280 : Record the last piece of info needed by + * 'TclGetSrcInfoForPc', and push the frame. + */ - cleanup = 1; - pc += 1; - TEBC_YIELD(); - return TclNREvalObjEx(interp, OBJ_AT_TOS, 0, NULL, 0); - - case INST_INVOKE_EXPANDED: - CLANG_ASSERT(auxObjList); - objc = CURR_DEPTH - auxObjList->internalRep.ptrAndLongRep.value; - POP_TAUX_OBJ(); - if (objc) { - pcAdjustment = 1; - goto doInvocation; - } +#ifdef TCL_TIP280 + bcFrame.data.tebc.pc = (char*) pc; + iPtr->cmdFramePtr = &bcFrame; + TclArgumentBCEnter((Tcl_Interp*) iPtr, objv, objc, + codePtr, &bcFrame, + pc - codePtr->codeStart); +#endif + DECACHE_STACK_INFO(); + Tcl_ResetResult(interp); + result = TclEvalObjvInternal(interp, objc, objv, bytes, length, 0); + CACHE_STACK_INFO(); +#ifdef TCL_TIP280 + TclArgumentBCRelease((Tcl_Interp*) iPtr, objv, objc, + codePtr, + pc - codePtr->codeStart); + iPtr->cmdFramePtr = iPtr->cmdFramePtr->nextPtr; +#endif - /* - * Nothing was expanded, return {}. - */ + /* + * If the old stack is going to be released, it is + * safe to do so now, since no references to objv are + * going to be used from now on. + */ - TclNewObj(objResultPtr); - NEXT_INST_F(1, 0, 1); + --*preservedStackRefCountPtr; + if (*preservedStackRefCountPtr == (char *) 0) { + ckfree((VOID *) preservedStackRefCountPtr); + } - case INST_INVOKE_STK4: - objc = TclGetUInt4AtPtr(pc+1); - pcAdjustment = 5; - goto doInvocation; + if (result == TCL_OK) { + /* + * Push the call's object result and continue execution + * with the next instruction. + */ - case INST_INVOKE_STK1: - objc = TclGetUInt1AtPtr(pc+1); - pcAdjustment = 2; + TRACE_WITH_OBJ(("%u => ... after \"%.20s\": TCL_OK, result=", + objc, cmdNameBuf), Tcl_GetObjResult(interp)); - doInvocation: - objv = &OBJ_AT_DEPTH(objc-1); - cleanup = objc; + objResultPtr = Tcl_GetObjResult(interp); -#ifdef TCL_COMPILE_DEBUG - if (tclTraceExec >= 2) { - int i; + /* + * Reset the interp's result to avoid possible duplications + * of large objects [Bug 781585]. We do not call + * Tcl_ResetResult() to avoid any side effects caused by + * the resetting of errorInfo and errorCode [Bug 804681], + * which are not needed here. We chose instead to manipulate + * the interp's object result directly. + * + * Note that the result object is now in objResultPtr, it + * keeps the refCount it had in its role of iPtr->objResultPtr. + */ + { + Tcl_Obj *newObjResultPtr; + TclNewObj(newObjResultPtr); + Tcl_IncrRefCount(newObjResultPtr); + iPtr->objResultPtr = newObjResultPtr; + } - if (traceInstructions) { - strncpy(cmdNameBuf, TclGetString(objv[0]), 20); - TRACE(("%u => call ", objc)); + NEXT_INST_V(pcAdjustment, opnd, -1); } else { - fprintf(stdout, "%d: (%u) invoking ", iPtr->numLevels, - (unsigned)(pc - codePtr->codeStart)); + cleanup = opnd; + goto processExceptionReturn; } - for (i = 0; i < objc; i++) { - TclPrintObject(stdout, objv[i], 15); - fprintf(stdout, " "); - } - fprintf(stdout, "\n"); - fflush(stdout); } -#endif /*TCL_COMPILE_DEBUG*/ + case INST_EVAL_STK: /* - * Finally, let TclEvalObjv handle the command. - * - * TIP #280: Record the last piece of info needed by - * 'TclGetSrcInfoForPc', and push the frame. + * Note to maintainers: it is important that INST_EVAL_STK + * pop its argument from the stack before jumping to + * checkForCatch! DO NOT OPTIMISE! */ - bcFramePtr->data.tebc.pc = (char *) pc; - iPtr->cmdFramePtr = bcFramePtr; - - if (iPtr->flags & INTERP_DEBUG_FRAME) { - TclArgumentBCEnter((Tcl_Interp *) iPtr, objv, objc, - codePtr, bcFramePtr, pc - codePtr->codeStart); - } - + objPtr = stackPtr[stackTop]; DECACHE_STACK_INFO(); - - pc += pcAdjustment; - TEBC_YIELD(); - return TclNREvalObjv(interp, objc, objv, - TCL_EVAL_NOERR, NULL); - -#if TCL_SUPPORT_84_BYTECODE - case INST_CALL_BUILTIN_FUNC1: - /* - * Call one of the built-in pre-8.5 Tcl math functions. This - * translates to INST_INVOKE_STK1 with the first argument of - * ::tcl::mathfunc::$objv[0]. We need to insert the named math - * function into the stack. +#ifndef TCL_TIP280 + result = TclCompEvalObj(interp, objPtr); +#else + /* TIP #280: The invoking context is left NULL for a dynamically + * constructed command. We cannot match its lines to the outer + * context. */ - opnd = TclGetUInt1AtPtr(pc+1); - if ((opnd < 0) || (opnd > LAST_BUILTIN_FUNC)) { - TRACE(("UNRECOGNIZED BUILTIN FUNC CODE %d\n", opnd)); - Tcl_Panic("TclNRExecuteByteCode: unrecognized builtin function code %d", opnd); - } - - TclNewLiteralStringObj(objPtr, "::tcl::mathfunc::"); - Tcl_AppendToObj(objPtr, tclBuiltinFuncTable[opnd].name, -1); + result = TclCompEvalObj(interp, objPtr, NULL,0); +#endif + CACHE_STACK_INFO(); + if (result == TCL_OK) { + /* + * Normal return; push the eval's object result. + */ - /* - * Only 0, 1 or 2 args. - */ + objResultPtr = Tcl_GetObjResult(interp); + TRACE_WITH_OBJ(("\"%.30s\" => ", O2S(objPtr)), + Tcl_GetObjResult(interp)); - { - int numArgs = tclBuiltinFuncTable[opnd].numArgs; - Tcl_Obj *tmpPtr1, *tmpPtr2; - - if (numArgs == 0) { - PUSH_OBJECT(objPtr); - } else if (numArgs == 1) { - tmpPtr1 = POP_OBJECT(); - PUSH_OBJECT(objPtr); - PUSH_OBJECT(tmpPtr1); - Tcl_DecrRefCount(tmpPtr1); - } else { - tmpPtr2 = POP_OBJECT(); - tmpPtr1 = POP_OBJECT(); - PUSH_OBJECT(objPtr); - PUSH_OBJECT(tmpPtr1); - PUSH_OBJECT(tmpPtr2); - Tcl_DecrRefCount(tmpPtr1); - Tcl_DecrRefCount(tmpPtr2); + /* + * Reset the interp's result to avoid possible duplications + * of large objects [Bug 781585]. We do not call + * Tcl_ResetResult() to avoid any side effects caused by + * the resetting of errorInfo and errorCode [Bug 804681], + * which are not needed here. We chose instead to manipulate + * the interp's object result directly. + * + * Note that the result object is now in objResultPtr, it + * keeps the refCount it had in its role of iPtr->objResultPtr. + */ + { + Tcl_Obj *newObjResultPtr; + TclNewObj(newObjResultPtr); + Tcl_IncrRefCount(newObjResultPtr); + iPtr->objResultPtr = newObjResultPtr; } - objc = numArgs + 1; - } - pcAdjustment = 2; - goto doInvocation; - - case INST_CALL_FUNC1: - /* - * Call a non-builtin Tcl math function previously registered by a - * call to Tcl_CreateMathFunc pre-8.5. This is essentially - * INST_INVOKE_STK1 converting the first arg to - * ::tcl::mathfunc::$objv[0]. - */ - - objc = TclGetUInt1AtPtr(pc+1); /* Number of arguments. The function - * name is the 0-th argument. */ - - objPtr = OBJ_AT_DEPTH(objc-1); - TclNewLiteralStringObj(tmpPtr, "::tcl::mathfunc::"); - Tcl_AppendObjToObj(tmpPtr, objPtr); - Tcl_DecrRefCount(objPtr); - - /* - * Variation of PUSH_OBJECT. - */ - - OBJ_AT_DEPTH(objc-1) = tmpPtr; - Tcl_IncrRefCount(tmpPtr); - pcAdjustment = 2; - goto doInvocation; -#else - /* - * INST_CALL_BUILTIN_FUNC1 and INST_CALL_FUNC1 were made obsolete by the - * changes to add a ::tcl::mathfunc namespace in 8.5. Optional support - * remains for existing bytecode precompiled files. - */ + NEXT_INST_F(1, 1, -1); + } else { + cleanup = 1; + goto processExceptionReturn; + } - case INST_CALL_BUILTIN_FUNC1: - Tcl_Panic("TclNRExecuteByteCode: obsolete INST_CALL_BUILTIN_FUNC1 found"); - case INST_CALL_FUNC1: - Tcl_Panic("TclNRExecuteByteCode: obsolete INST_CALL_FUNC1 found"); -#endif + case INST_EXPR_STK: + objPtr = stackPtr[stackTop]; + DECACHE_STACK_INFO(); + Tcl_ResetResult(interp); + result = Tcl_ExprObj(interp, objPtr, &valuePtr); + CACHE_STACK_INFO(); + if (result != TCL_OK) { + TRACE_WITH_OBJ(("\"%.30s\" => ERROR: ", + O2S(objPtr)), Tcl_GetObjResult(interp)); + goto checkForCatch; + } + objResultPtr = valuePtr; + TRACE_WITH_OBJ(("\"%.30s\" => ", O2S(objPtr)), valuePtr); + NEXT_INST_F(1, 1, -1); /* already has right refct */ /* - * ----------------------------------------------------------------- - * Start of INST_LOAD instructions. + * --------------------------------------------------------- + * Start of INST_LOAD instructions. * - * WARNING: more 'goto' here than your doctor recommended! The different - * instructions set the value of some variables and then jump to some - * common execution code. + * WARNING: more 'goto' here than your doctor recommended! + * The different instructions set the value of some variables + * and then jump to somme common execution code. */ case INST_LOAD_SCALAR1: - instLoadScalar1: opnd = TclGetUInt1AtPtr(pc+1); - varPtr = LOCAL(opnd); + varPtr = &(varFramePtr->compiledLocals[opnd]); + part1 = varPtr->name; while (TclIsVarLink(varPtr)) { varPtr = varPtr->value.linkPtr; } TRACE(("%u => ", opnd)); - if (TclIsVarDirectReadable(varPtr)) { + if (TclIsVarScalar(varPtr) && !TclIsVarUndefined(varPtr) + && (varPtr->tracePtr == NULL)) { /* * No errors, no traces: just get the value. */ - objResultPtr = varPtr->value.objPtr; TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); NEXT_INST_F(2, 0, 1); @@ -2905,21 +1739,22 @@ TEBCresume( pcAdjustment = 2; cleanup = 0; arrayPtr = NULL; - part1Ptr = part2Ptr = NULL; + part2 = NULL; goto doCallPtrGetVar; case INST_LOAD_SCALAR4: opnd = TclGetUInt4AtPtr(pc+1); - varPtr = LOCAL(opnd); + varPtr = &(varFramePtr->compiledLocals[opnd]); + part1 = varPtr->name; while (TclIsVarLink(varPtr)) { varPtr = varPtr->value.linkPtr; } TRACE(("%u => ", opnd)); - if (TclIsVarDirectReadable(varPtr)) { + if (TclIsVarScalar(varPtr) && !TclIsVarUndefined(varPtr) + && (varPtr->tracePtr == NULL)) { /* * No errors, no traces: just get the value. */ - objResultPtr = varPtr->value.objPtr; TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); NEXT_INST_F(5, 0, 1); @@ -2927,263 +1762,193 @@ TEBCresume( pcAdjustment = 5; cleanup = 0; arrayPtr = NULL; - part1Ptr = part2Ptr = NULL; - goto doCallPtrGetVar; - - case INST_LOAD_ARRAY4: - opnd = TclGetUInt4AtPtr(pc+1); - pcAdjustment = 5; - goto doLoadArray; - - case INST_LOAD_ARRAY1: - opnd = TclGetUInt1AtPtr(pc+1); - pcAdjustment = 2; - - doLoadArray: - part1Ptr = NULL; - part2Ptr = OBJ_AT_TOS; - arrayPtr = LOCAL(opnd); - while (TclIsVarLink(arrayPtr)) { - arrayPtr = arrayPtr->value.linkPtr; - } - TRACE(("%u \"%.30s\" => ", opnd, O2S(part2Ptr))); - if (TclIsVarArray(arrayPtr) && !ReadTraced(arrayPtr)) { - varPtr = VarHashFindVar(arrayPtr->value.tablePtr, part2Ptr); - if (varPtr && TclIsVarDirectReadable(varPtr)) { - /* - * No errors, no traces: just get the value. - */ - - objResultPtr = varPtr->value.objPtr; - TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); - NEXT_INST_F(pcAdjustment, 1, 1); - } - } - varPtr = TclLookupArrayElement(interp, part1Ptr, part2Ptr, - TCL_LEAVE_ERR_MSG, "read", 0, 1, arrayPtr, opnd); - if (varPtr == NULL) { - TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); - goto gotError; - } - cleanup = 1; + part2 = NULL; goto doCallPtrGetVar; case INST_LOAD_ARRAY_STK: cleanup = 2; - part2Ptr = OBJ_AT_TOS; /* element name */ - objPtr = OBJ_UNDER_TOS; /* array name */ - TRACE(("\"%.30s(%.30s)\" => ", O2S(objPtr), O2S(part2Ptr))); + part2 = Tcl_GetString(stackPtr[stackTop]); /* element name */ + objPtr = stackPtr[stackTop-1]; /* array name */ + TRACE(("\"%.30s(%.30s)\" => ", O2S(objPtr), part2)); goto doLoadStk; case INST_LOAD_STK: case INST_LOAD_SCALAR_STK: cleanup = 1; - part2Ptr = NULL; - objPtr = OBJ_AT_TOS; /* variable name */ + part2 = NULL; + objPtr = stackPtr[stackTop]; /* variable name */ TRACE(("\"%.30s\" => ", O2S(objPtr))); doLoadStk: - part1Ptr = objPtr; - varPtr = TclObjLookupVarEx(interp, part1Ptr, part2Ptr, - TCL_LEAVE_ERR_MSG, "read", /*createPart1*/0, /*createPart2*/1, - &arrayPtr); - if (!varPtr) { + part1 = TclGetString(objPtr); + varPtr = TclObjLookupVar(interp, objPtr, part2, + TCL_LEAVE_ERR_MSG, "read", + /*createPart1*/ 0, + /*createPart2*/ 1, &arrayPtr); + if (varPtr == NULL) { TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); - goto gotError; + result = TCL_ERROR; + goto checkForCatch; } - - if (TclIsVarDirectReadable2(varPtr, arrayPtr)) { + if (TclIsVarScalar(varPtr) && !TclIsVarUndefined(varPtr) + && (varPtr->tracePtr == NULL) + && ((arrayPtr == NULL) + || (arrayPtr->tracePtr == NULL))) { /* * No errors, no traces: just get the value. */ - objResultPtr = varPtr->value.objPtr; TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); NEXT_INST_V(1, cleanup, 1); } pcAdjustment = 1; - opnd = -1; - - doCallPtrGetVar: - /* - * There are either errors or the variable is traced: call - * TclPtrGetVar to process fully. - */ - - DECACHE_STACK_INFO(); - objResultPtr = TclPtrGetVar(interp, varPtr, arrayPtr, - part1Ptr, part2Ptr, TCL_LEAVE_ERR_MSG, opnd); - CACHE_STACK_INFO(); - if (!objResultPtr) { - TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); - goto gotError; - } - TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); - NEXT_INST_V(pcAdjustment, cleanup, 1); - - /* - * End of INST_LOAD instructions. - * ----------------------------------------------------------------- - * Start of INST_STORE and related instructions. - * - * WARNING: more 'goto' here than your doctor recommended! The different - * instructions set the value of some variables and then jump to somme - * common execution code. - */ - - { - int storeFlags; + goto doCallPtrGetVar; - case INST_STORE_ARRAY4: + case INST_LOAD_ARRAY4: opnd = TclGetUInt4AtPtr(pc+1); pcAdjustment = 5; - goto doStoreArrayDirect; + goto doLoadArray; - case INST_STORE_ARRAY1: + case INST_LOAD_ARRAY1: opnd = TclGetUInt1AtPtr(pc+1); pcAdjustment = 2; - - doStoreArrayDirect: - valuePtr = OBJ_AT_TOS; - part2Ptr = OBJ_UNDER_TOS; - arrayPtr = LOCAL(opnd); - TRACE(("%u \"%.30s\" <- \"%.30s\" => ", opnd, O2S(part2Ptr), - O2S(valuePtr))); + + doLoadArray: + part2 = TclGetString(stackPtr[stackTop]); + arrayPtr = &(varFramePtr->compiledLocals[opnd]); + part1 = arrayPtr->name; while (TclIsVarLink(arrayPtr)) { arrayPtr = arrayPtr->value.linkPtr; } - if (TclIsVarArray(arrayPtr) && !WriteTraced(arrayPtr)) { - varPtr = VarHashFindVar(arrayPtr->value.tablePtr, part2Ptr); - if (varPtr && TclIsVarDirectWritable(varPtr)) { - tosPtr--; - Tcl_DecrRefCount(OBJ_AT_TOS); - OBJ_AT_TOS = valuePtr; - goto doStoreVarDirect; - } - } - cleanup = 2; - storeFlags = TCL_LEAVE_ERR_MSG; - part1Ptr = NULL; - goto doStoreArrayDirectFailed; - - case INST_STORE_SCALAR4: - opnd = TclGetUInt4AtPtr(pc+1); - pcAdjustment = 5; - goto doStoreScalarDirect; - - case INST_STORE_SCALAR1: - opnd = TclGetUInt1AtPtr(pc+1); - pcAdjustment = 2; - - doStoreScalarDirect: - valuePtr = OBJ_AT_TOS; - varPtr = LOCAL(opnd); - TRACE(("%u <- \"%.30s\" => ", opnd, O2S(valuePtr))); - while (TclIsVarLink(varPtr)) { - varPtr = varPtr->value.linkPtr; + TRACE(("%u \"%.30s\" => ", opnd, part2)); + varPtr = TclLookupArrayElement(interp, part1, part2, + TCL_LEAVE_ERR_MSG, "read", 0, 1, arrayPtr); + if (varPtr == NULL) { + TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); + result = TCL_ERROR; + goto checkForCatch; } - if (!TclIsVarDirectWritable(varPtr)) { - storeFlags = TCL_LEAVE_ERR_MSG; - part1Ptr = NULL; - goto doStoreScalar; + if (TclIsVarScalar(varPtr) && !TclIsVarUndefined(varPtr) + && (varPtr->tracePtr == NULL) + && ((arrayPtr == NULL) + || (arrayPtr->tracePtr == NULL))) { + /* + * No errors, no traces: just get the value. + */ + objResultPtr = varPtr->value.objPtr; + TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); + NEXT_INST_F(pcAdjustment, 1, 1); } + cleanup = 1; + goto doCallPtrGetVar; + doCallPtrGetVar: /* - * No traces, no errors, plain 'set': we can safely inline. The value - * *will* be set to what's requested, so that the stack top remains - * pointing to the same Tcl_Obj. + * There are either errors or the variable is traced: + * call TclPtrGetVar to process fully. */ - doStoreVarDirect: - valuePtr = varPtr->value.objPtr; - if (valuePtr != NULL) { - TclDecrRefCount(valuePtr); - } - objResultPtr = OBJ_AT_TOS; - varPtr->value.objPtr = objResultPtr; -#ifndef TCL_COMPILE_DEBUG - if (*(pc+pcAdjustment) == INST_POP) { - tosPtr--; - NEXT_INST_F((pcAdjustment+1), 0, 0); + DECACHE_STACK_INFO(); + objResultPtr = TclPtrGetVar(interp, varPtr, arrayPtr, part1, + part2, TCL_LEAVE_ERR_MSG); + CACHE_STACK_INFO(); + if (objResultPtr == NULL) { + TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); + result = TCL_ERROR; + goto checkForCatch; } -#else TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); -#endif - Tcl_IncrRefCount(objResultPtr); - NEXT_INST_F(pcAdjustment, 0, 0); + NEXT_INST_V(pcAdjustment, cleanup, 1); + + /* + * End of INST_LOAD instructions. + * --------------------------------------------------------- + */ + + /* + * --------------------------------------------------------- + * Start of INST_STORE and related instructions. + * + * WARNING: more 'goto' here than your doctor recommended! + * The different instructions set the value of some variables + * and then jump to somme common execution code. + */ case INST_LAPPEND_STK: - valuePtr = OBJ_AT_TOS; /* value to append */ - part2Ptr = NULL; - storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE - | TCL_LIST_ELEMENT); + valuePtr = stackPtr[stackTop]; /* value to append */ + part2 = NULL; + storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE + | TCL_LIST_ELEMENT); goto doStoreStk; case INST_LAPPEND_ARRAY_STK: - valuePtr = OBJ_AT_TOS; /* value to append */ - part2Ptr = OBJ_UNDER_TOS; - storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE - | TCL_LIST_ELEMENT); + valuePtr = stackPtr[stackTop]; /* value to append */ + part2 = TclGetString(stackPtr[stackTop - 1]); + storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE + | TCL_LIST_ELEMENT); goto doStoreStk; case INST_APPEND_STK: - valuePtr = OBJ_AT_TOS; /* value to append */ - part2Ptr = NULL; + valuePtr = stackPtr[stackTop]; /* value to append */ + part2 = NULL; storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE); goto doStoreStk; case INST_APPEND_ARRAY_STK: - valuePtr = OBJ_AT_TOS; /* value to append */ - part2Ptr = OBJ_UNDER_TOS; + valuePtr = stackPtr[stackTop]; /* value to append */ + part2 = TclGetString(stackPtr[stackTop - 1]); storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE); goto doStoreStk; case INST_STORE_ARRAY_STK: - valuePtr = OBJ_AT_TOS; - part2Ptr = OBJ_UNDER_TOS; + valuePtr = stackPtr[stackTop]; + part2 = TclGetString(stackPtr[stackTop - 1]); storeFlags = TCL_LEAVE_ERR_MSG; goto doStoreStk; case INST_STORE_STK: case INST_STORE_SCALAR_STK: - valuePtr = OBJ_AT_TOS; - part2Ptr = NULL; + valuePtr = stackPtr[stackTop]; + part2 = NULL; storeFlags = TCL_LEAVE_ERR_MSG; doStoreStk: - objPtr = OBJ_AT_DEPTH(1 + (part2Ptr != NULL)); /* variable name */ - part1Ptr = objPtr; + objPtr = stackPtr[stackTop - 1 - (part2 != NULL)]; /* variable name */ + part1 = TclGetString(objPtr); #ifdef TCL_COMPILE_DEBUG - if (part2Ptr == NULL) { - TRACE(("\"%.30s\" <- \"%.30s\" =>", O2S(part1Ptr),O2S(valuePtr))); + if (part2 == NULL) { + TRACE(("\"%.30s\" <- \"%.30s\" =>", + part1, O2S(valuePtr))); } else { TRACE(("\"%.30s(%.30s)\" <- \"%.30s\" => ", - O2S(part1Ptr), O2S(part2Ptr), O2S(valuePtr))); + part1, part2, O2S(valuePtr))); } #endif - varPtr = TclObjLookupVarEx(interp, objPtr,part2Ptr, TCL_LEAVE_ERR_MSG, - "set", /*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr); - if (!varPtr) { + varPtr = TclObjLookupVar(interp, objPtr, part2, + TCL_LEAVE_ERR_MSG, "set", + /*createPart1*/ 1, + /*createPart2*/ 1, &arrayPtr); + if (varPtr == NULL) { TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); - goto gotError; + result = TCL_ERROR; + goto checkForCatch; } - cleanup = ((part2Ptr == NULL)? 2 : 3); + cleanup = ((part2 == NULL)? 2 : 3); pcAdjustment = 1; - opnd = -1; goto doCallPtrSetVar; case INST_LAPPEND_ARRAY4: opnd = TclGetUInt4AtPtr(pc+1); pcAdjustment = 5; - storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE - | TCL_LIST_ELEMENT); + storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE + | TCL_LIST_ELEMENT); goto doStoreArray; case INST_LAPPEND_ARRAY1: opnd = TclGetUInt1AtPtr(pc+1); pcAdjustment = 2; - storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE - | TCL_LIST_ELEMENT); + storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE + | TCL_LIST_ELEMENT); goto doStoreArray; case INST_APPEND_ARRAY4: @@ -3198,39 +1963,49 @@ TEBCresume( storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE); goto doStoreArray; + case INST_STORE_ARRAY4: + opnd = TclGetUInt4AtPtr(pc+1); + pcAdjustment = 5; + storeFlags = TCL_LEAVE_ERR_MSG; + goto doStoreArray; + + case INST_STORE_ARRAY1: + opnd = TclGetUInt1AtPtr(pc+1); + pcAdjustment = 2; + storeFlags = TCL_LEAVE_ERR_MSG; + doStoreArray: - valuePtr = OBJ_AT_TOS; - part2Ptr = OBJ_UNDER_TOS; - arrayPtr = LOCAL(opnd); - TRACE(("%u \"%.30s\" <- \"%.30s\" => ", opnd, O2S(part2Ptr), - O2S(valuePtr))); + valuePtr = stackPtr[stackTop]; + part2 = TclGetString(stackPtr[stackTop - 1]); + arrayPtr = &(varFramePtr->compiledLocals[opnd]); + part1 = arrayPtr->name; + TRACE(("%u \"%.30s\" <- \"%.30s\" => ", + opnd, part2, O2S(valuePtr))); while (TclIsVarLink(arrayPtr)) { arrayPtr = arrayPtr->value.linkPtr; } - cleanup = 2; - part1Ptr = NULL; - - doStoreArrayDirectFailed: - varPtr = TclLookupArrayElement(interp, part1Ptr, part2Ptr, - TCL_LEAVE_ERR_MSG, "set", 1, 1, arrayPtr, opnd); - if (!varPtr) { + varPtr = TclLookupArrayElement(interp, part1, part2, + TCL_LEAVE_ERR_MSG, "set", 1, 1, arrayPtr); + if (varPtr == NULL) { TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); - goto gotError; + result = TCL_ERROR; + goto checkForCatch; } + cleanup = 2; goto doCallPtrSetVar; case INST_LAPPEND_SCALAR4: opnd = TclGetUInt4AtPtr(pc+1); pcAdjustment = 5; - storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE - | TCL_LIST_ELEMENT); + storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE + | TCL_LIST_ELEMENT); goto doStoreScalar; case INST_LAPPEND_SCALAR1: opnd = TclGetUInt1AtPtr(pc+1); - pcAdjustment = 2; - storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE - | TCL_LIST_ELEMENT); + pcAdjustment = 2; + storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE + | TCL_LIST_ELEMENT); goto doStoreScalar; case INST_APPEND_SCALAR4: @@ -3241,29 +2016,77 @@ TEBCresume( case INST_APPEND_SCALAR1: opnd = TclGetUInt1AtPtr(pc+1); - pcAdjustment = 2; + pcAdjustment = 2; storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE); goto doStoreScalar; + case INST_STORE_SCALAR4: + opnd = TclGetUInt4AtPtr(pc+1); + pcAdjustment = 5; + storeFlags = TCL_LEAVE_ERR_MSG; + goto doStoreScalar; + + case INST_STORE_SCALAR1: + opnd = TclGetUInt1AtPtr(pc+1); + pcAdjustment = 2; + storeFlags = TCL_LEAVE_ERR_MSG; + doStoreScalar: - valuePtr = OBJ_AT_TOS; - varPtr = LOCAL(opnd); + valuePtr = stackPtr[stackTop]; + varPtr = &(varFramePtr->compiledLocals[opnd]); + part1 = varPtr->name; TRACE(("%u <- \"%.30s\" => ", opnd, O2S(valuePtr))); while (TclIsVarLink(varPtr)) { varPtr = varPtr->value.linkPtr; } cleanup = 1; arrayPtr = NULL; - part1Ptr = part2Ptr = NULL; + part2 = NULL; doCallPtrSetVar: - DECACHE_STACK_INFO(); - objResultPtr = TclPtrSetVar(interp, varPtr, arrayPtr, - part1Ptr, part2Ptr, valuePtr, storeFlags, opnd); - CACHE_STACK_INFO(); - if (!objResultPtr) { - TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); - goto gotError; + if ((storeFlags == TCL_LEAVE_ERR_MSG) + && !((varPtr->flags & VAR_IN_HASHTABLE) + && (varPtr->hPtr == NULL)) + && (varPtr->tracePtr == NULL) + && (TclIsVarScalar(varPtr) + || TclIsVarUndefined(varPtr)) + && ((arrayPtr == NULL) + || (arrayPtr->tracePtr == NULL))) { + /* + * No traces, no errors, plain 'set': we can safely inline. + * The value *will* be set to what's requested, so that + * the stack top remains pointing to the same Tcl_Obj. + */ + valuePtr = varPtr->value.objPtr; + objResultPtr = stackPtr[stackTop]; + if (valuePtr != objResultPtr) { + if (valuePtr != NULL) { + TclDecrRefCount(valuePtr); + } else { + TclSetVarScalar(varPtr); + TclClearVarUndefined(varPtr); + } + varPtr->value.objPtr = objResultPtr; + Tcl_IncrRefCount(objResultPtr); + } +#ifndef TCL_COMPILE_DEBUG + if (*(pc+pcAdjustment) == INST_POP) { + NEXT_INST_V((pcAdjustment+1), cleanup, 0); + } +#else + TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); +#endif + NEXT_INST_V(pcAdjustment, cleanup, 1); + } else { + DECACHE_STACK_INFO(); + objResultPtr = TclPtrSetVar(interp, varPtr, arrayPtr, + part1, part2, valuePtr, storeFlags); + CACHE_STACK_INFO(); + if (objResultPtr == NULL) { + TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); + result = TCL_ERROR; + goto checkForCatch; + } } #ifndef TCL_COMPILE_DEBUG if (*(pc+pcAdjustment) == INST_POP) { @@ -3272,26 +2095,21 @@ TEBCresume( #endif TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); NEXT_INST_V(pcAdjustment, cleanup, 1); - } + /* - * End of INST_STORE and related instructions. - * ----------------------------------------------------------------- - * Start of INST_INCR instructions. - * - * WARNING: more 'goto' here than your doctor recommended! The different - * instructions set the value of some variables and then jump to somme - * common execution code. + * End of INST_STORE and related instructions. + * --------------------------------------------------------- */ -/*TODO: Consider more untangling here; merge with LOAD and STORE ? */ - - { - Tcl_Obj *incrPtr; -#ifndef NO_WIDE_TYPE - Tcl_WideInt w; -#endif - long increment; + /* + * --------------------------------------------------------- + * Start of INST_INCR instructions. + * + * WARNING: more 'goto' here than your doctor recommended! + * The different instructions set the value of some variables + * and then jump to somme common execution code. + */ case INST_INCR_SCALAR1: case INST_INCR_ARRAY1: @@ -3299,240 +2117,147 @@ TEBCresume( case INST_INCR_SCALAR_STK: case INST_INCR_STK: opnd = TclGetUInt1AtPtr(pc+1); - incrPtr = POP_OBJECT(); + valuePtr = stackPtr[stackTop]; + if (valuePtr->typePtr == &tclIntType) { + i = valuePtr->internalRep.longValue; + } else if (valuePtr->typePtr == &tclWideIntType) { + TclGetLongFromWide(i,valuePtr); + } else { + REQUIRE_WIDE_OR_INT(result, valuePtr, i, w); + if (result != TCL_OK) { + TRACE_WITH_OBJ(("%u (by %s) => ERROR converting increment amount to int: ", + opnd, O2S(valuePtr)), Tcl_GetObjResult(interp)); + DECACHE_STACK_INFO(); + Tcl_AddErrorInfo(interp, "\n (reading increment)"); + CACHE_STACK_INFO(); + goto checkForCatch; + } + FORCE_LONG(valuePtr, i, w); + } + stackTop--; + TclDecrRefCount(valuePtr); switch (*pc) { - case INST_INCR_SCALAR1: - pcAdjustment = 2; - goto doIncrScalar; - case INST_INCR_ARRAY1: - pcAdjustment = 2; - goto doIncrArray; - default: - pcAdjustment = 1; - goto doIncrStk; + case INST_INCR_SCALAR1: + pcAdjustment = 2; + goto doIncrScalar; + case INST_INCR_ARRAY1: + pcAdjustment = 2; + goto doIncrArray; + default: + pcAdjustment = 1; + goto doIncrStk; } case INST_INCR_ARRAY_STK_IMM: case INST_INCR_SCALAR_STK_IMM: case INST_INCR_STK_IMM: - increment = TclGetInt1AtPtr(pc+1); - incrPtr = Tcl_NewIntObj(increment); - Tcl_IncrRefCount(incrPtr); + i = TclGetInt1AtPtr(pc+1); pcAdjustment = 2; - + doIncrStk: - if ((*pc == INST_INCR_ARRAY_STK_IMM) - || (*pc == INST_INCR_ARRAY_STK)) { - part2Ptr = OBJ_AT_TOS; - objPtr = OBJ_UNDER_TOS; + if ((*pc == INST_INCR_ARRAY_STK_IMM) + || (*pc == INST_INCR_ARRAY_STK)) { + part2 = TclGetString(stackPtr[stackTop]); + objPtr = stackPtr[stackTop - 1]; TRACE(("\"%.30s(%.30s)\" (by %ld) => ", - O2S(objPtr), O2S(part2Ptr), increment)); + O2S(objPtr), part2, i)); } else { - part2Ptr = NULL; - objPtr = OBJ_AT_TOS; - TRACE(("\"%.30s\" (by %ld) => ", O2S(objPtr), increment)); + part2 = NULL; + objPtr = stackPtr[stackTop]; + TRACE(("\"%.30s\" (by %ld) => ", O2S(objPtr), i)); } - part1Ptr = objPtr; - opnd = -1; - varPtr = TclObjLookupVarEx(interp, objPtr, part2Ptr, - TCL_LEAVE_ERR_MSG, "read", 1, 1, &arrayPtr); - if (!varPtr) { + part1 = TclGetString(objPtr); + + varPtr = TclObjLookupVar(interp, objPtr, part2, + TCL_LEAVE_ERR_MSG, "read", 0, 1, &arrayPtr); + if (varPtr == NULL) { + DECACHE_STACK_INFO(); Tcl_AddObjErrorInfo(interp, - "\n (reading value of variable to increment)", -1); + "\n (reading value of variable to increment)", -1); + CACHE_STACK_INFO(); TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); - Tcl_DecrRefCount(incrPtr); - goto gotError; + result = TCL_ERROR; + goto checkForCatch; } - cleanup = ((part2Ptr == NULL)? 1 : 2); + cleanup = ((part2 == NULL)? 1 : 2); goto doIncrVar; case INST_INCR_ARRAY1_IMM: opnd = TclGetUInt1AtPtr(pc+1); - increment = TclGetInt1AtPtr(pc+2); - incrPtr = Tcl_NewIntObj(increment); - Tcl_IncrRefCount(incrPtr); + i = TclGetInt1AtPtr(pc+2); pcAdjustment = 3; doIncrArray: - part1Ptr = NULL; - part2Ptr = OBJ_AT_TOS; - arrayPtr = LOCAL(opnd); - cleanup = 1; + part2 = TclGetString(stackPtr[stackTop]); + arrayPtr = &(varFramePtr->compiledLocals[opnd]); + part1 = arrayPtr->name; while (TclIsVarLink(arrayPtr)) { arrayPtr = arrayPtr->value.linkPtr; } - TRACE(("%u \"%.30s\" (by %ld) => ", opnd, O2S(part2Ptr), increment)); - varPtr = TclLookupArrayElement(interp, part1Ptr, part2Ptr, - TCL_LEAVE_ERR_MSG, "read", 1, 1, arrayPtr, opnd); - if (!varPtr) { + TRACE(("%u \"%.30s\" (by %ld) => ", + opnd, part2, i)); + varPtr = TclLookupArrayElement(interp, part1, part2, + TCL_LEAVE_ERR_MSG, "read", 0, 1, arrayPtr); + if (varPtr == NULL) { TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); - Tcl_DecrRefCount(incrPtr); - goto gotError; + result = TCL_ERROR; + goto checkForCatch; } + cleanup = 1; goto doIncrVar; case INST_INCR_SCALAR1_IMM: opnd = TclGetUInt1AtPtr(pc+1); - increment = TclGetInt1AtPtr(pc+2); + i = TclGetInt1AtPtr(pc+2); pcAdjustment = 3; - cleanup = 0; - varPtr = LOCAL(opnd); - while (TclIsVarLink(varPtr)) { - varPtr = varPtr->value.linkPtr; - } - - if (TclIsVarDirectModifyable(varPtr)) { - ClientData ptr; - int type; - - objPtr = varPtr->value.objPtr; - if (GetNumberFromObj(NULL, objPtr, &ptr, &type) == TCL_OK) { - if (type == TCL_NUMBER_LONG) { - long augend = *((const long *)ptr); - long sum = augend + increment; - - /* - * Overflow when (augend and sum have different sign) and - * (augend and increment have the same sign). This is - * encapsulated in the Overflowing macro. - */ - - if (!Overflowing(augend, increment, sum)) { - TRACE(("%u %ld => ", opnd, increment)); - if (Tcl_IsShared(objPtr)) { - objPtr->refCount--; /* We know it's shared. */ - TclNewLongObj(objResultPtr, sum); - Tcl_IncrRefCount(objResultPtr); - varPtr->value.objPtr = objResultPtr; - } else { - objResultPtr = objPtr; - TclSetLongObj(objPtr, sum); - } - goto doneIncr; - } -#ifndef NO_WIDE_TYPE - w = (Tcl_WideInt)augend; - - TRACE(("%u %ld => ", opnd, increment)); - if (Tcl_IsShared(objPtr)) { - objPtr->refCount--; /* We know it's shared. */ - objResultPtr = Tcl_NewWideIntObj(w+increment); - Tcl_IncrRefCount(objResultPtr); - varPtr->value.objPtr = objResultPtr; - } else { - objResultPtr = objPtr; - - /* - * We know the sum value is outside the long range; - * use macro form that doesn't range test again. - */ - - TclSetWideIntObj(objPtr, w+increment); - } - goto doneIncr; -#endif - } /* end if (type == TCL_NUMBER_LONG) */ -#ifndef NO_WIDE_TYPE - if (type == TCL_NUMBER_WIDE) { - Tcl_WideInt sum; - - w = *((const Tcl_WideInt *) ptr); - sum = w + increment; - - /* - * Check for overflow. - */ - - if (!Overflowing(w, increment, sum)) { - TRACE(("%u %ld => ", opnd, increment)); - if (Tcl_IsShared(objPtr)) { - objPtr->refCount--; /* We know it's shared. */ - objResultPtr = Tcl_NewWideIntObj(sum); - Tcl_IncrRefCount(objResultPtr); - varPtr->value.objPtr = objResultPtr; - } else { - objResultPtr = objPtr; - - /* - * We *do not* know the sum value is outside the - * long range (wide + long can yield long); use - * the function call that checks range. - */ - - Tcl_SetWideIntObj(objPtr, sum); - } - goto doneIncr; - } - } -#endif - } - if (Tcl_IsShared(objPtr)) { - objPtr->refCount--; /* We know it's shared */ - objResultPtr = Tcl_DuplicateObj(objPtr); - Tcl_IncrRefCount(objResultPtr); - varPtr->value.objPtr = objResultPtr; - } else { - objResultPtr = objPtr; - } - TclNewLongObj(incrPtr, increment); - if (TclIncrObj(interp, objResultPtr, incrPtr) != TCL_OK) { - Tcl_DecrRefCount(incrPtr); - TRACE_APPEND(("ERROR: %.30s\n", - O2S(Tcl_GetObjResult(interp)))); - goto gotError; - } - Tcl_DecrRefCount(incrPtr); - goto doneIncr; - } - - /* - * All other cases, flow through to generic handling. - */ - - TclNewLongObj(incrPtr, increment); - Tcl_IncrRefCount(incrPtr); doIncrScalar: - varPtr = LOCAL(opnd); + varPtr = &(varFramePtr->compiledLocals[opnd]); + part1 = varPtr->name; while (TclIsVarLink(varPtr)) { varPtr = varPtr->value.linkPtr; } arrayPtr = NULL; - part1Ptr = part2Ptr = NULL; + part2 = NULL; cleanup = 0; - TRACE(("%u %ld => ", opnd, increment)); + TRACE(("%u %ld => ", opnd, i)); + doIncrVar: - if (TclIsVarDirectModifyable2(varPtr, arrayPtr)) { - objPtr = varPtr->value.objPtr; + objPtr = varPtr->value.objPtr; + if (TclIsVarScalar(varPtr) + && !TclIsVarUndefined(varPtr) + && (varPtr->tracePtr == NULL) + && ((arrayPtr == NULL) + || (arrayPtr->tracePtr == NULL)) + && (objPtr->typePtr == &tclIntType)) { + /* + * No errors, no traces, the variable already has an + * integer value: inline processing. + */ + + i += objPtr->internalRep.longValue; if (Tcl_IsShared(objPtr)) { - objPtr->refCount--; /* We know it's shared */ - objResultPtr = Tcl_DuplicateObj(objPtr); + objResultPtr = Tcl_NewLongObj(i); + TclDecrRefCount(objPtr); Tcl_IncrRefCount(objResultPtr); varPtr->value.objPtr = objResultPtr; } else { + Tcl_SetLongObj(objPtr, i); objResultPtr = objPtr; } - if (TclIncrObj(interp, objResultPtr, incrPtr) != TCL_OK) { - Tcl_DecrRefCount(incrPtr); - TRACE_APPEND(("ERROR: %.30s\n", - O2S(Tcl_GetObjResult(interp)))); - goto gotError; - } - Tcl_DecrRefCount(incrPtr); + TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); } else { DECACHE_STACK_INFO(); - objResultPtr = TclPtrIncrObjVar(interp, varPtr, arrayPtr, - part1Ptr, part2Ptr, incrPtr, TCL_LEAVE_ERR_MSG, opnd); + objResultPtr = TclPtrIncrVar(interp, varPtr, arrayPtr, part1, + part2, i, TCL_LEAVE_ERR_MSG); CACHE_STACK_INFO(); - Tcl_DecrRefCount(incrPtr); if (objResultPtr == NULL) { - TRACE_APPEND(("ERROR: %.30s\n", - O2S(Tcl_GetObjResult(interp)))); - goto gotError; + TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); + result = TCL_ERROR; + goto checkForCatch; } } - doneIncr: TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); #ifndef TCL_COMPILE_DEBUG if (*(pc+pcAdjustment) == INST_POP) { @@ -3540,1277 +2265,895 @@ TEBCresume( } #endif NEXT_INST_V(pcAdjustment, cleanup, 1); - } - - /* - * End of INST_INCR instructions. - * ----------------------------------------------------------------- - * Start of INST_EXIST instructions. - */ - - case INST_EXIST_SCALAR: - opnd = TclGetUInt4AtPtr(pc+1); - varPtr = LOCAL(opnd); - while (TclIsVarLink(varPtr)) { - varPtr = varPtr->value.linkPtr; - } - TRACE(("%u => ", opnd)); - if (ReadTraced(varPtr)) { - DECACHE_STACK_INFO(); - TclObjCallVarTraces(iPtr, NULL, varPtr, NULL, NULL, - TCL_TRACE_READS, 0, opnd); - CACHE_STACK_INFO(); - if (TclIsVarUndefined(varPtr)) { - TclCleanupVar(varPtr, NULL); - varPtr = NULL; - } - } - - /* - * Tricky! Arrays always exist. - */ - - objResultPtr = TCONST(!varPtr || TclIsVarUndefined(varPtr) ? 0 : 1); - TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); - NEXT_INST_F(5, 0, 1); - - case INST_EXIST_ARRAY: - opnd = TclGetUInt4AtPtr(pc+1); - part2Ptr = OBJ_AT_TOS; - arrayPtr = LOCAL(opnd); - while (TclIsVarLink(arrayPtr)) { - arrayPtr = arrayPtr->value.linkPtr; - } - TRACE(("%u \"%.30s\" => ", opnd, O2S(part2Ptr))); - if (TclIsVarArray(arrayPtr) && !ReadTraced(arrayPtr)) { - varPtr = VarHashFindVar(arrayPtr->value.tablePtr, part2Ptr); - if (!varPtr || !ReadTraced(varPtr)) { - goto doneExistArray; - } - } - varPtr = TclLookupArrayElement(interp, NULL, part2Ptr, 0, "access", - 0, 1, arrayPtr, opnd); - if (varPtr) { - if (ReadTraced(varPtr) || (arrayPtr && ReadTraced(arrayPtr))) { - DECACHE_STACK_INFO(); - TclObjCallVarTraces(iPtr, arrayPtr, varPtr, NULL, part2Ptr, - TCL_TRACE_READS, 0, opnd); - CACHE_STACK_INFO(); - } - if (TclIsVarUndefined(varPtr)) { - TclCleanupVar(varPtr, arrayPtr); - varPtr = NULL; - } - } - doneExistArray: - objResultPtr = TCONST(!varPtr || TclIsVarUndefined(varPtr) ? 0 : 1); - TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); - NEXT_INST_F(5, 1, 1); - - case INST_EXIST_ARRAY_STK: - cleanup = 2; - part2Ptr = OBJ_AT_TOS; /* element name */ - part1Ptr = OBJ_UNDER_TOS; /* array name */ - TRACE(("\"%.30s(%.30s)\" => ", O2S(part1Ptr), O2S(part2Ptr))); - goto doExistStk; - - case INST_EXIST_STK: - cleanup = 1; - part2Ptr = NULL; - part1Ptr = OBJ_AT_TOS; /* variable name */ - TRACE(("\"%.30s\" => ", O2S(part1Ptr))); - - doExistStk: - varPtr = TclObjLookupVarEx(interp, part1Ptr, part2Ptr, 0, "access", - /*createPart1*/0, /*createPart2*/1, &arrayPtr); - if (varPtr) { - if (ReadTraced(varPtr) || (arrayPtr && ReadTraced(arrayPtr))) { - DECACHE_STACK_INFO(); - TclObjCallVarTraces(iPtr, arrayPtr, varPtr, part1Ptr,part2Ptr, - TCL_TRACE_READS, 0, -1); - CACHE_STACK_INFO(); - } - if (TclIsVarUndefined(varPtr)) { - TclCleanupVar(varPtr, arrayPtr); - varPtr = NULL; - } - } - objResultPtr = TCONST(!varPtr || TclIsVarUndefined(varPtr) ? 0 : 1); - TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); - NEXT_INST_V(1, cleanup, 1); - - /* - * End of INST_EXIST instructions. - * ----------------------------------------------------------------- - * Start of INST_UNSET instructions. - */ - - { - int flags; - - case INST_UNSET_SCALAR: - flags = TclGetUInt1AtPtr(pc+1) ? TCL_LEAVE_ERR_MSG : 0; - opnd = TclGetUInt4AtPtr(pc+2); - varPtr = LOCAL(opnd); - while (TclIsVarLink(varPtr)) { - varPtr = varPtr->value.linkPtr; - } - TRACE(("%s %u\n", (flags?"normal":"noerr"), opnd)); - if (TclIsVarDirectUnsettable(varPtr) && !TclIsVarInHash(varPtr)) { - /* - * No errors, no traces, no searches: just make the variable cease - * to exist. - */ - - if (!TclIsVarUndefined(varPtr)) { - TclDecrRefCount(varPtr->value.objPtr); - } else if (flags & TCL_LEAVE_ERR_MSG) { - goto slowUnsetScalar; - } - varPtr->value.objPtr = NULL; - NEXT_INST_F(6, 0, 0); - } - - slowUnsetScalar: - DECACHE_STACK_INFO(); - if (TclPtrUnsetVar(interp, varPtr, NULL, NULL, NULL, flags, - opnd) != TCL_OK && flags) { - goto errorInUnset; - } - CACHE_STACK_INFO(); - NEXT_INST_F(6, 0, 0); - - case INST_UNSET_ARRAY: - flags = TclGetUInt1AtPtr(pc+1) ? TCL_LEAVE_ERR_MSG : 0; - opnd = TclGetUInt4AtPtr(pc+2); - part2Ptr = OBJ_AT_TOS; - arrayPtr = LOCAL(opnd); - while (TclIsVarLink(arrayPtr)) { - arrayPtr = arrayPtr->value.linkPtr; - } - TRACE(("%s %u \"%.30s\"\n", - (flags ? "normal" : "noerr"), opnd, O2S(part2Ptr))); - if (TclIsVarArray(arrayPtr) && !UnsetTraced(arrayPtr)) { - varPtr = VarHashFindVar(arrayPtr->value.tablePtr, part2Ptr); - if (varPtr && TclIsVarDirectUnsettable(varPtr)) { - /* - * No nasty traces and element exists, so we can proceed to - * unset it. Might still not exist though... - */ - - if (!TclIsVarUndefined(varPtr)) { - TclDecrRefCount(varPtr->value.objPtr); - } else if (flags & TCL_LEAVE_ERR_MSG) { - goto slowUnsetArray; - } - varPtr->value.objPtr = NULL; - NEXT_INST_F(6, 1, 0); - } else if (!varPtr && !(flags & TCL_LEAVE_ERR_MSG)) { - /* - * Don't need to do anything here. - */ - - NEXT_INST_F(6, 1, 0); - } - } - slowUnsetArray: - DECACHE_STACK_INFO(); - varPtr = TclLookupArrayElement(interp, NULL, part2Ptr, flags, "unset", - 0, 0, arrayPtr, opnd); - if (!varPtr) { - if (flags & TCL_LEAVE_ERR_MSG) { - goto errorInUnset; - } - } else if (TclPtrUnsetVar(interp, varPtr, arrayPtr, NULL, part2Ptr, - flags, opnd) != TCL_OK && (flags & TCL_LEAVE_ERR_MSG)) { - goto errorInUnset; - } - CACHE_STACK_INFO(); - NEXT_INST_F(6, 1, 0); - - case INST_UNSET_ARRAY_STK: - flags = TclGetUInt1AtPtr(pc+1) ? TCL_LEAVE_ERR_MSG : 0; - cleanup = 2; - part2Ptr = OBJ_AT_TOS; /* element name */ - part1Ptr = OBJ_UNDER_TOS; /* array name */ - TRACE(("%s \"%.30s(%.30s)\"\n", (flags?"normal":"noerr"), - O2S(part1Ptr), O2S(part2Ptr))); - goto doUnsetStk; - - case INST_UNSET_STK: - flags = TclGetUInt1AtPtr(pc+1) ? TCL_LEAVE_ERR_MSG : 0; - cleanup = 1; - part2Ptr = NULL; - part1Ptr = OBJ_AT_TOS; /* variable name */ - TRACE(("%s \"%.30s\"\n", (flags?"normal":"noerr"), O2S(part1Ptr))); - - doUnsetStk: - DECACHE_STACK_INFO(); - if (TclObjUnsetVar2(interp, part1Ptr, part2Ptr, flags) != TCL_OK - && (flags & TCL_LEAVE_ERR_MSG)) { - goto errorInUnset; - } - CACHE_STACK_INFO(); - NEXT_INST_V(2, cleanup, 0); - - errorInUnset: - CACHE_STACK_INFO(); - TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); - goto gotError; - - /* - * This is really an unset operation these days. Do not issue. - */ - - case INST_DICT_DONE: - opnd = TclGetUInt4AtPtr(pc+1); - TRACE(("%u\n", opnd)); - varPtr = LOCAL(opnd); - while (TclIsVarLink(varPtr)) { - varPtr = varPtr->value.linkPtr; - } - if (TclIsVarDirectUnsettable(varPtr) && !TclIsVarInHash(varPtr)) { - if (!TclIsVarUndefined(varPtr)) { - TclDecrRefCount(varPtr->value.objPtr); - } - varPtr->value.objPtr = NULL; - } else { - DECACHE_STACK_INFO(); - TclPtrUnsetVar(interp, varPtr, NULL, NULL, NULL, 0, opnd); - CACHE_STACK_INFO(); - } - NEXT_INST_F(5, 0, 0); - } - + /* - * End of INST_UNSET instructions. - * ----------------------------------------------------------------- - * Start of variable linking instructions. + * End of INST_INCR instructions. + * --------------------------------------------------------- */ - { - Var *otherPtr; - CallFrame *framePtr, *savedFramePtr; - Tcl_Namespace *nsPtr; - Namespace *savedNsPtr; - - case INST_UPVAR: - TRACE_WITH_OBJ(("upvar "), OBJ_UNDER_TOS); - - if (TclObjGetFrame(interp, OBJ_UNDER_TOS, &framePtr) == -1) { - goto gotError; - } - - /* - * Locate the other variable. - */ - - savedFramePtr = iPtr->varFramePtr; - iPtr->varFramePtr = framePtr; - otherPtr = TclObjLookupVarEx(interp, OBJ_AT_TOS, NULL, - TCL_LEAVE_ERR_MSG, "access", /*createPart1*/ 1, - /*createPart2*/ 1, &varPtr); - iPtr->varFramePtr = savedFramePtr; - if (!otherPtr) { - goto gotError; - } - goto doLinkVars; - - case INST_NSUPVAR: - TRACE_WITH_OBJ(("nsupvar "), OBJ_UNDER_TOS); - if (TclGetNamespaceFromObj(interp, OBJ_UNDER_TOS, &nsPtr) != TCL_OK) { - goto gotError; - } - - /* - * Locate the other variable. - */ - - savedNsPtr = iPtr->varFramePtr->nsPtr; - iPtr->varFramePtr->nsPtr = (Namespace *) nsPtr; - otherPtr = TclObjLookupVarEx(interp, OBJ_AT_TOS, NULL, - (TCL_NAMESPACE_ONLY | TCL_LEAVE_ERR_MSG), "access", - /*createPart1*/ 1, /*createPart2*/ 1, &varPtr); - iPtr->varFramePtr->nsPtr = savedNsPtr; - if (!otherPtr) { - goto gotError; - } - goto doLinkVars; - - case INST_VARIABLE: - TRACE(("variable ")); - otherPtr = TclObjLookupVarEx(interp, OBJ_AT_TOS, NULL, - (TCL_NAMESPACE_ONLY | TCL_LEAVE_ERR_MSG), "access", - /*createPart1*/ 1, /*createPart2*/ 1, &varPtr); - if (!otherPtr) { - goto gotError; - } - - /* - * Do the [variable] magic. - */ - - TclSetVarNamespaceVar(otherPtr); - - doLinkVars: - - /* - * If we are here, the local variable has already been created: do the - * little work of TclPtrMakeUpvar that remains to be done right here - * if there are no errors; otherwise, let it handle the case. - */ - - opnd = TclGetInt4AtPtr(pc+1);; - varPtr = LOCAL(opnd); - if ((varPtr != otherPtr) && !TclIsVarTraced(varPtr) - && (TclIsVarUndefined(varPtr) || TclIsVarLink(varPtr))) { - if (!TclIsVarUndefined(varPtr)) { - /* - * Then it is a defined link. - */ - - Var *linkPtr = varPtr->value.linkPtr; - - if (linkPtr == otherPtr) { - NEXT_INST_F(5, 1, 0); - } - if (TclIsVarInHash(linkPtr)) { - VarHashRefCount(linkPtr)--; - if (TclIsVarUndefined(linkPtr)) { - TclCleanupVar(linkPtr, NULL); - } - } - } - TclSetVarLink(varPtr); - varPtr->value.linkPtr = otherPtr; - if (TclIsVarInHash(otherPtr)) { - VarHashRefCount(otherPtr)++; - } - } else if (TclPtrObjMakeUpvar(interp, otherPtr, NULL, 0, - opnd) != TCL_OK) { - goto gotError; - } - - /* - * Do not pop the namespace or frame index, it may be needed for other - * variables - and [variable] did not push it at all. - */ - - NEXT_INST_F(5, 1, 0); - } - - /* - * End of variable linking instructions. - * ----------------------------------------------------------------- - */ case INST_JUMP1: opnd = TclGetInt1AtPtr(pc+1); TRACE(("%d => new pc %u\n", opnd, - (unsigned)(pc + opnd - codePtr->codeStart))); + (unsigned int)(pc + opnd - codePtr->codeStart))); NEXT_INST_F(opnd, 0, 0); case INST_JUMP4: opnd = TclGetInt4AtPtr(pc+1); TRACE(("%d => new pc %u\n", opnd, - (unsigned)(pc + opnd - codePtr->codeStart))); + (unsigned int)(pc + opnd - codePtr->codeStart))); NEXT_INST_F(opnd, 0, 0); - { - int jmpOffset[2], b; - - /* TODO: consider rewrite so we don't compute the offset we're not - * going to take. */ case INST_JUMP_FALSE4: - jmpOffset[0] = TclGetInt4AtPtr(pc+1); /* FALSE offset */ - jmpOffset[1] = 5; /* TRUE offset */ - goto doCondJump; + opnd = 5; /* TRUE */ + pcAdjustment = TclGetInt4AtPtr(pc+1); /* FALSE */ + goto doJumpTrue; case INST_JUMP_TRUE4: - jmpOffset[0] = 5; - jmpOffset[1] = TclGetInt4AtPtr(pc+1); - goto doCondJump; + opnd = TclGetInt4AtPtr(pc+1); /* TRUE */ + pcAdjustment = 5; /* FALSE */ + goto doJumpTrue; case INST_JUMP_FALSE1: - jmpOffset[0] = TclGetInt1AtPtr(pc+1); - jmpOffset[1] = 2; - goto doCondJump; + opnd = 2; /* TRUE */ + pcAdjustment = TclGetInt1AtPtr(pc+1); /* FALSE */ + goto doJumpTrue; case INST_JUMP_TRUE1: - jmpOffset[0] = 2; - jmpOffset[1] = TclGetInt1AtPtr(pc+1); - - doCondJump: - valuePtr = OBJ_AT_TOS; - - /* TODO - check claim that taking address of b harms performance */ - /* TODO - consider optimization search for constants */ - if (TclGetBooleanFromObj(interp, valuePtr, &b) != TCL_OK) { - TRACE_WITH_OBJ(("%d => ERROR: ", jmpOffset[ - ((*pc == INST_JUMP_FALSE1) || (*pc == INST_JUMP_FALSE4)) - ? 0 : 1]), Tcl_GetObjResult(interp)); - goto gotError; - } - -#ifdef TCL_COMPILE_DEBUG - if (b) { - if ((*pc == INST_JUMP_TRUE1) || (*pc == INST_JUMP_TRUE4)) { - TRACE(("%d => %.20s true, new pc %u\n", jmpOffset[1], - O2S(valuePtr), - (unsigned)(pc + jmpOffset[1] - codePtr->codeStart))); + opnd = TclGetInt1AtPtr(pc+1); /* TRUE */ + pcAdjustment = 2; /* FALSE */ + + doJumpTrue: + { + int b; + + valuePtr = stackPtr[stackTop]; + if (valuePtr->typePtr == &tclIntType) { + b = (valuePtr->internalRep.longValue != 0); + } else if (valuePtr->typePtr == &tclDoubleType) { + b = (valuePtr->internalRep.doubleValue != 0.0); + } else if (valuePtr->typePtr == &tclWideIntType) { + TclGetWide(w,valuePtr); + b = (w != W0); } else { - TRACE(("%d => %.20s true\n", jmpOffset[0], O2S(valuePtr))); + result = Tcl_GetBooleanFromObj(interp, valuePtr, &b); + if (result != TCL_OK) { + TRACE_WITH_OBJ(("%d => ERROR: ", opnd), Tcl_GetObjResult(interp)); + goto checkForCatch; + } } - } else { - if ((*pc == INST_JUMP_TRUE1) || (*pc == INST_JUMP_TRUE4)) { - TRACE(("%d => %.20s false\n", jmpOffset[0], O2S(valuePtr))); +#ifndef TCL_COMPILE_DEBUG + NEXT_INST_F((b? opnd : pcAdjustment), 1, 0); +#else + if (b) { + if ((*pc == INST_JUMP_TRUE1) || (*pc == INST_JUMP_TRUE1)) { + TRACE(("%d => %.20s true, new pc %u\n", opnd, O2S(valuePtr), + (unsigned int)(pc+opnd - codePtr->codeStart))); + } else { + TRACE(("%d => %.20s true\n", pcAdjustment, O2S(valuePtr))); + } + NEXT_INST_F(opnd, 1, 0); } else { - TRACE(("%d => %.20s false, new pc %u\n", jmpOffset[0], - O2S(valuePtr), - (unsigned)(pc + jmpOffset[1] - codePtr->codeStart))); + if ((*pc == INST_JUMP_TRUE1) || (*pc == INST_JUMP_TRUE1)) { + TRACE(("%d => %.20s false\n", opnd, O2S(valuePtr))); + } else { + opnd = pcAdjustment; + TRACE(("%d => %.20s false, new pc %u\n", opnd, O2S(valuePtr), + (unsigned int)(pc + opnd - codePtr->codeStart))); + } + NEXT_INST_F(pcAdjustment, 1, 0); } - } #endif - NEXT_INST_F(jmpOffset[b], 1, 0); - } - - case INST_JUMP_TABLE: { - Tcl_HashEntry *hPtr; - JumptableInfo *jtPtr; - - /* - * Jump to location looked up in a hashtable; fall through to next - * instr if lookup fails. - */ - - opnd = TclGetInt4AtPtr(pc+1); - jtPtr = (JumptableInfo *) codePtr->auxDataArrayPtr[opnd].clientData; - TRACE(("%d => %.20s ", opnd, O2S(OBJ_AT_TOS))); - hPtr = Tcl_FindHashEntry(&jtPtr->hashTable, TclGetString(OBJ_AT_TOS)); - if (hPtr != NULL) { - int jumpOffset = PTR2INT(Tcl_GetHashValue(hPtr)); - - TRACE_APPEND(("found in table, new pc %u\n", - (unsigned)(pc - codePtr->codeStart + jumpOffset))); - NEXT_INST_F(jumpOffset, 1, 0); - } else { - TRACE_APPEND(("not found in table\n")); - NEXT_INST_F(5, 1, 0); } - } - - /* - * These two instructions are now redundant: the complete logic of the LOR - * and LAND is now handled by the expression compiler. - */ - + case INST_LOR: - case INST_LAND: { + case INST_LAND: + { /* - * Operands must be boolean or numeric. No int->double conversions are - * performed. + * Operands must be boolean or numeric. No int->double + * conversions are performed. */ - - int i1, i2, iResult; - - value2Ptr = OBJ_AT_TOS; - valuePtr = OBJ_UNDER_TOS; - if (TclGetBooleanFromObj(NULL, valuePtr, &i1) != TCL_OK) { - TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(valuePtr), - (valuePtr->typePtr? valuePtr->typePtr->name : "null"))); - DECACHE_STACK_INFO(); - IllegalExprOperandType(interp, pc, valuePtr); - CACHE_STACK_INFO(); - goto gotError; + + int i1, i2; + int iResult; + char *s; + Tcl_ObjType *t1Ptr, *t2Ptr; + + value2Ptr = stackPtr[stackTop]; + valuePtr = stackPtr[stackTop - 1];; + t1Ptr = valuePtr->typePtr; + t2Ptr = value2Ptr->typePtr; + + if ((t1Ptr == &tclIntType) || (t1Ptr == &tclBooleanType)) { + i1 = (valuePtr->internalRep.longValue != 0); + } else if (t1Ptr == &tclWideIntType) { + TclGetWide(w,valuePtr); + i1 = (w != W0); + } else if (t1Ptr == &tclDoubleType) { + i1 = (valuePtr->internalRep.doubleValue != 0.0); + } else { + s = Tcl_GetStringFromObj(valuePtr, &length); + if (TclLooksLikeInt(s, length)) { + GET_WIDE_OR_INT(result, valuePtr, i, w); + if (valuePtr->typePtr == &tclIntType) { + i1 = (i != 0); + } else { + i1 = (w != W0); + } + } else { + result = Tcl_GetBooleanFromObj((Tcl_Interp *) NULL, + valuePtr, &i1); + i1 = (i1 != 0); + } + if (result != TCL_OK) { + TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(valuePtr), + (t1Ptr? t1Ptr->name : "null"))); + DECACHE_STACK_INFO(); + IllegalExprOperandType(interp, pc, valuePtr); + CACHE_STACK_INFO(); + goto checkForCatch; + } } - - if (TclGetBooleanFromObj(NULL, value2Ptr, &i2) != TCL_OK) { - TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(value2Ptr), - (value2Ptr->typePtr? value2Ptr->typePtr->name : "null"))); - DECACHE_STACK_INFO(); - IllegalExprOperandType(interp, pc, value2Ptr); - CACHE_STACK_INFO(); - goto gotError; + + if ((t2Ptr == &tclIntType) || (t2Ptr == &tclBooleanType)) { + i2 = (value2Ptr->internalRep.longValue != 0); + } else if (t2Ptr == &tclWideIntType) { + TclGetWide(w,value2Ptr); + i2 = (w != W0); + } else if (t2Ptr == &tclDoubleType) { + i2 = (value2Ptr->internalRep.doubleValue != 0.0); + } else { + s = Tcl_GetStringFromObj(value2Ptr, &length); + if (TclLooksLikeInt(s, length)) { + GET_WIDE_OR_INT(result, value2Ptr, i, w); + if (value2Ptr->typePtr == &tclIntType) { + i2 = (i != 0); + } else { + i2 = (w != W0); + } + } else { + result = Tcl_GetBooleanFromObj((Tcl_Interp *) NULL, value2Ptr, &i2); + } + if (result != TCL_OK) { + TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(value2Ptr), + (t2Ptr? t2Ptr->name : "null"))); + DECACHE_STACK_INFO(); + IllegalExprOperandType(interp, pc, value2Ptr); + CACHE_STACK_INFO(); + goto checkForCatch; + } } + /* + * Reuse the valuePtr object already on stack if possible. + */ + if (*pc == INST_LOR) { iResult = (i1 || i2); } else { iResult = (i1 && i2); } - objResultPtr = TCONST(iResult); - TRACE(("%.20s %.20s => %d\n", O2S(valuePtr),O2S(value2Ptr),iResult)); - NEXT_INST_F(1, 2, 1); + if (Tcl_IsShared(valuePtr)) { + objResultPtr = Tcl_NewLongObj(iResult); + TRACE(("%.20s %.20s => %d\n", O2S(valuePtr), O2S(value2Ptr), iResult)); + NEXT_INST_F(1, 2, 1); + } else { /* reuse the valuePtr object */ + TRACE(("%.20s %.20s => %d\n", O2S(valuePtr), O2S(value2Ptr), iResult)); + Tcl_SetLongObj(valuePtr, iResult); + NEXT_INST_F(1, 1, 0); + } } /* - * ----------------------------------------------------------------- - * Start of INST_LIST and related instructions. + * --------------------------------------------------------- + * Start of INST_LIST and related instructions. */ - { - int index, numIndices, fromIdx, toIdx; - int nocase, match, length2, cflags, s1len, s2len; - const char *s1, *s2; - case INST_LIST: /* - * Pop the opnd (objc) top stack elements into a new list obj and then - * decrement their ref counts. + * Pop the opnd (objc) top stack elements into a new list obj + * and then decrement their ref counts. */ opnd = TclGetUInt4AtPtr(pc+1); - objResultPtr = Tcl_NewListObj(opnd, &OBJ_AT_DEPTH(opnd-1)); + objResultPtr = Tcl_NewListObj(opnd, &(stackPtr[stackTop - (opnd-1)])); TRACE_WITH_OBJ(("%u => ", opnd), objResultPtr); NEXT_INST_V(5, opnd, 1); case INST_LIST_LENGTH: - valuePtr = OBJ_AT_TOS; - if (TclListObjLength(interp, valuePtr, &length) != TCL_OK) { + valuePtr = stackPtr[stackTop]; + + result = Tcl_ListObjLength(interp, valuePtr, &length); + if (result != TCL_OK) { TRACE_WITH_OBJ(("%.30s => ERROR: ", O2S(valuePtr)), - Tcl_GetObjResult(interp)); - goto gotError; + Tcl_GetObjResult(interp)); + goto checkForCatch; } - TclNewIntObj(objResultPtr, length); + objResultPtr = Tcl_NewIntObj(length); TRACE(("%.20s => %d\n", O2S(valuePtr), length)); NEXT_INST_F(1, 1, 1); - - case INST_LIST_INDEX: /* lindex with objc == 3 */ - value2Ptr = OBJ_AT_TOS; - valuePtr = OBJ_UNDER_TOS; - - /* - * Extract the desired list element. - */ - - if ((TclListObjGetElements(interp, valuePtr, &objc, &objv) == TCL_OK) - && (value2Ptr->typePtr != &tclListType) - && (TclGetIntForIndexM(NULL , value2Ptr, objc-1, - &index) == TCL_OK)) { - TclDecrRefCount(value2Ptr); - tosPtr--; - pcAdjustment = 1; - goto lindexFastPath; - } - - objResultPtr = TclLindexList(interp, valuePtr, value2Ptr); - if (!objResultPtr) { - TRACE_WITH_OBJ(("%.30s %.30s => ERROR: ", O2S(valuePtr), - O2S(value2Ptr)), Tcl_GetObjResult(interp)); - goto gotError; - } - + + case INST_LIST_INDEX: + /*** lindex with objc == 3 ***/ + /* - * Stash the list element on the stack. + * Pop the two operands */ - - TRACE(("%.20s %.20s => %s\n", - O2S(valuePtr), O2S(value2Ptr), O2S(objResultPtr))); - NEXT_INST_F(1, 2, -1); /* Already has the correct refCount */ - - case INST_LIST_INDEX_IMM: /* lindex with objc==3 and index in bytecode - * stream */ + value2Ptr = stackPtr[stackTop]; + valuePtr = stackPtr[stackTop- 1]; /* - * Pop the list and get the index. + * Extract the desired list element */ - - valuePtr = OBJ_AT_TOS; - opnd = TclGetInt4AtPtr(pc+1); - - /* - * Get the contents of the list, making sure that it really is a list - * in the process. - */ - - if (TclListObjGetElements(interp, valuePtr, &objc, &objv) != TCL_OK) { - TRACE_WITH_OBJ(("\"%.30s\" %d => ERROR: ", O2S(valuePtr), opnd), - Tcl_GetObjResult(interp)); - goto gotError; + objResultPtr = TclLindexList(interp, valuePtr, value2Ptr); + if (objResultPtr == NULL) { + TRACE_WITH_OBJ(("%.30s %.30s => ERROR: ", O2S(valuePtr), O2S(value2Ptr)), + Tcl_GetObjResult(interp)); + result = TCL_ERROR; + goto checkForCatch; } /* - * Select the list item based on the index. Negative operand means - * end-based indexing. + * Stash the list element on the stack */ + TRACE(("%.20s %.20s => %s\n", + O2S(valuePtr), O2S(value2Ptr), O2S(objResultPtr))); + NEXT_INST_F(1, 2, -1); /* already has the correct refCount */ - if (opnd < -1) { - index = opnd+1 + objc; - } else { - index = opnd; - } - pcAdjustment = 5; - - lindexFastPath: - if (index >= 0 && index < objc) { - objResultPtr = objv[index]; - } else { - TclNewObj(objResultPtr); - } - - TRACE_WITH_OBJ(("\"%.30s\" %d => ", O2S(valuePtr), opnd), - objResultPtr); - NEXT_INST_F(pcAdjustment, 1, 1); - - case INST_LIST_INDEX_MULTI: /* 'lindex' with multiple index args */ + case INST_LIST_INDEX_MULTI: + { /* + * 'lindex' with multiple index args: + * * Determine the count of index args. */ + int numIdx; + opnd = TclGetUInt4AtPtr(pc+1); - numIndices = opnd-1; + numIdx = opnd-1; /* * Do the 'lindex' operation. */ + objResultPtr = TclLindexFlat(interp, stackPtr[stackTop - numIdx], + numIdx, stackPtr + stackTop - numIdx + 1); - objResultPtr = TclLindexFlat(interp, OBJ_AT_DEPTH(numIndices), - numIndices, &OBJ_AT_DEPTH(numIndices - 1)); - if (!objResultPtr) { + /* + * Check for errors + */ + if (objResultPtr == NULL) { TRACE_WITH_OBJ(("%d => ERROR: ", opnd), Tcl_GetObjResult(interp)); - goto gotError; + result = TCL_ERROR; + goto checkForCatch; } /* - * Set result. + * Set result */ - TRACE(("%d => %s\n", opnd, O2S(objResultPtr))); NEXT_INST_V(5, opnd, -1); + } case INST_LSET_FLAT: + { /* - * Lset with 3, 5, or more args. Get the number of index args. + * Lset with 3, 5, or more args. Get the number + * of index args. */ + int numIdx; - opnd = TclGetUInt4AtPtr(pc + 1); - numIndices = opnd - 2; + opnd = TclGetUInt4AtPtr( pc + 1 ); + numIdx = opnd - 2; /* - * Get the old value of variable, and remove the stack ref. This is - * safe because the variable still references the object; the ref - * count will never go zero here - we can use the smaller macro - * Tcl_DecrRefCount. + * Get the old value of variable, and remove the stack ref. + * This is safe because the variable still references the + * object; the ref count will never go zero here. */ - - valuePtr = POP_OBJECT(); - Tcl_DecrRefCount(valuePtr); /* This one should be done here */ + value2Ptr = POP_OBJECT(); + TclDecrRefCount(value2Ptr); /* This one should be done here */ /* - * Compute the new variable value. + * Get the new element value. */ - - objResultPtr = TclLsetFlat(interp, valuePtr, numIndices, - &OBJ_AT_DEPTH(numIndices), OBJ_AT_TOS); - if (!objResultPtr) { - TRACE_WITH_OBJ(("%d => ERROR: ", opnd), Tcl_GetObjResult(interp)); - goto gotError; - } + valuePtr = stackPtr[stackTop]; /* - * Set result. + * Compute the new variable value */ + objResultPtr = TclLsetFlat(interp, value2Ptr, numIdx, + stackPtr + stackTop - numIdx, valuePtr); - TRACE(("%d => %s\n", opnd, O2S(objResultPtr))); - NEXT_INST_V(5, numIndices+1, -1); - case INST_LSET_LIST: /* 'lset' with 4 args */ /* - * Get the old value of variable, and remove the stack ref. This is - * safe because the variable still references the object; the ref - * count will never go zero here - we can use the smaller macro - * Tcl_DecrRefCount. + * Check for errors */ - - objPtr = POP_OBJECT(); - Tcl_DecrRefCount(objPtr); /* This one should be done here. */ + if (objResultPtr == NULL) { + TRACE_WITH_OBJ(("%d => ERROR: ", opnd), Tcl_GetObjResult(interp)); + result = TCL_ERROR; + goto checkForCatch; + } /* - * Get the new element value, and the index list. + * Set result */ + TRACE(("%d => %s\n", opnd, O2S(objResultPtr))); + NEXT_INST_V(5, (numIdx+1), -1); + } - valuePtr = OBJ_AT_TOS; - value2Ptr = OBJ_UNDER_TOS; - + case INST_LSET_LIST: /* - * Compute the new variable value. + * 'lset' with 4 args. + * + * Get the old value of variable, and remove the stack ref. + * This is safe because the variable still references the + * object; the ref count will never go zero here. */ - - objResultPtr = TclLsetList(interp, objPtr, value2Ptr, valuePtr); - if (!objResultPtr) { - TRACE_WITH_OBJ(("\"%.30s\" => ERROR: ", O2S(value2Ptr)), - Tcl_GetObjResult(interp)); - goto gotError; - } - + objPtr = POP_OBJECT(); + TclDecrRefCount(objPtr); /* This one should be done here */ + /* - * Set result. + * Get the new element value, and the index list */ - - TRACE(("=> %s\n", O2S(objResultPtr))); - NEXT_INST_F(1, 2, -1); - - case INST_LIST_RANGE_IMM: /* lrange with objc==4 and both indices in - * bytecode stream */ - + valuePtr = stackPtr[stackTop]; + value2Ptr = stackPtr[stackTop - 1]; + /* - * Pop the list and get the indices. + * Compute the new variable value */ - - valuePtr = OBJ_AT_TOS; - fromIdx = TclGetInt4AtPtr(pc+1); - toIdx = TclGetInt4AtPtr(pc+5); - - /* - * Get the contents of the list, making sure that it really is a list - * in the process. - */ - - if (TclListObjGetElements(interp, valuePtr, &objc, &objv) != TCL_OK) { - TRACE_WITH_OBJ(("\"%.30s\" %d %d => ERROR: ", O2S(valuePtr), - fromIdx, toIdx), Tcl_GetObjResult(interp)); - goto gotError; - } + objResultPtr = TclLsetList(interp, objPtr, value2Ptr, valuePtr); /* - * Skip a lot of work if we're about to throw the result away (common - * with uses of [lassign]). + * Check for errors */ - -#ifndef TCL_COMPILE_DEBUG - if (*(pc+9) == INST_POP) { - NEXT_INST_F(10, 1, 0); + if (objResultPtr == NULL) { + TRACE_WITH_OBJ(("\"%.30s\" => ERROR: ", O2S(value2Ptr)), + Tcl_GetObjResult(interp)); + result = TCL_ERROR; + goto checkForCatch; } -#endif /* - * Adjust the indices for end-based handling. + * Set result */ + TRACE(("=> %s\n", O2S(objResultPtr))); + NEXT_INST_F(1, 2, -1); - if (fromIdx < -1) { - fromIdx += 1+objc; - if (fromIdx < -1) { - fromIdx = -1; - } - } else if (fromIdx > objc) { - fromIdx = objc; - } - if (toIdx < -1) { - toIdx += 1 + objc; - if (toIdx < -1) { - toIdx = -1; - } - } else if (toIdx > objc) { - toIdx = objc; - } + /* + * End of INST_LIST and related instructions. + * --------------------------------------------------------- + */ + case INST_STR_EQ: + case INST_STR_NEQ: + { /* - * Check if we are referring to a valid, non-empty list range, and if - * so, build the list of elements in that range. + * String (in)equality check */ + int iResult; - if (fromIdx<=toIdx && fromIdx<objc && toIdx>=0) { - if (fromIdx < 0) { - fromIdx = 0; - } - if (toIdx >= objc) { - toIdx = objc-1; - } - if (fromIdx == 0 && toIdx != objc-1 && !Tcl_IsShared(valuePtr)) { - /* - * BEWARE! This is looking inside the implementation of the - * list type. - */ - - List *listPtr = valuePtr->internalRep.twoPtrValue.ptr1; - - if (listPtr->refCount == 1) { - TRACE(("\"%.30s\" %d %d => ", O2S(valuePtr), - TclGetInt4AtPtr(pc+1), TclGetInt4AtPtr(pc+5))); - for (index=toIdx+1 ; index<objc-1 ; index++) { - TclDecrRefCount(objv[index]); - } - listPtr->elemCount = toIdx+1; - listPtr->canonicalFlag = 1; - TclInvalidateStringRep(valuePtr); - TRACE_APPEND(("%.30s\n", O2S(valuePtr))); - NEXT_INST_F(9, 0, 0); - } - } - objResultPtr = Tcl_NewListObj(toIdx-fromIdx+1, objv+fromIdx); - } else { - TclNewObj(objResultPtr); - } - - TRACE_WITH_OBJ(("\"%.30s\" %d %d => ", O2S(valuePtr), - TclGetInt4AtPtr(pc+1), TclGetInt4AtPtr(pc+5)), objResultPtr); - NEXT_INST_F(9, 1, 1); - - case INST_LIST_IN: - case INST_LIST_NOT_IN: /* Basic list containment operators. */ - value2Ptr = OBJ_AT_TOS; - valuePtr = OBJ_UNDER_TOS; - - s1 = TclGetStringFromObj(valuePtr, &s1len); - if (TclListObjLength(interp, value2Ptr, &length) != TCL_OK) { - TRACE_WITH_OBJ(("\"%.30s\" \"%.30s\" => ERROR: ", O2S(valuePtr), - O2S(value2Ptr)), Tcl_GetObjResult(interp)); - goto gotError; - } - match = 0; - if (length > 0) { - int i = 0; - Tcl_Obj *o; + value2Ptr = stackPtr[stackTop]; + valuePtr = stackPtr[stackTop - 1]; + if (valuePtr == value2Ptr) { /* - * An empty list doesn't match anything. + * On the off-chance that the objects are the same, + * we don't really have to think hard about equality. */ + iResult = (*pc == INST_STR_EQ); + } else { + char *s1, *s2; + int s1len, s2len; - do { - Tcl_ListObjIndex(NULL, value2Ptr, i, &o); - if (o != NULL) { - s2 = TclGetStringFromObj(o, &s2len); + s1 = Tcl_GetStringFromObj(valuePtr, &s1len); + s2 = Tcl_GetStringFromObj(value2Ptr, &s2len); + if (s1len == s2len) { + /* + * We only need to check (in)equality when + * we have equal length strings. + */ + if (*pc == INST_STR_NEQ) { + iResult = (strcmp(s1, s2) != 0); } else { - s2 = ""; - s2len = 0; - } - if (s1len == s2len) { - match = (memcmp(s1, s2, s1len) == 0); + /* INST_STR_EQ */ + iResult = (strcmp(s1, s2) == 0); } - i++; - } while (i < length && match == 0); + } else { + iResult = (*pc == INST_STR_NEQ); + } } - if (*pc == INST_LIST_NOT_IN) { - match = !match; - } - - TRACE(("%.20s %.20s => %d\n", O2S(valuePtr), O2S(value2Ptr), match)); + TRACE(("%.20s %.20s => %d\n", O2S(valuePtr), O2S(value2Ptr), iResult)); /* - * Peep-hole optimisation: if you're about to jump, do jump from here. - * We're saving the effort of pushing a boolean value only to pop it - * for branching. + * Peep-hole optimisation: if you're about to jump, do jump + * from here. */ pc++; #ifndef TCL_COMPILE_DEBUG switch (*pc) { - case INST_JUMP_FALSE1: - NEXT_INST_F((match ? 2 : TclGetInt1AtPtr(pc+1)), 2, 0); - case INST_JUMP_TRUE1: - NEXT_INST_F((match ? TclGetInt1AtPtr(pc+1) : 2), 2, 0); - case INST_JUMP_FALSE4: - NEXT_INST_F((match ? 5 : TclGetInt4AtPtr(pc+1)), 2, 0); - case INST_JUMP_TRUE4: - NEXT_INST_F((match ? TclGetInt4AtPtr(pc+1) : 5), 2, 0); + case INST_JUMP_FALSE1: + NEXT_INST_F((iResult? 2 : TclGetInt1AtPtr(pc+1)), 2, 0); + case INST_JUMP_TRUE1: + NEXT_INST_F((iResult? TclGetInt1AtPtr(pc+1) : 2), 2, 0); + case INST_JUMP_FALSE4: + NEXT_INST_F((iResult? 5 : TclGetInt4AtPtr(pc+1)), 2, 0); + case INST_JUMP_TRUE4: + NEXT_INST_F((iResult? TclGetInt4AtPtr(pc+1) : 5), 2, 0); } #endif - objResultPtr = TCONST(match); + objResultPtr = Tcl_NewIntObj(iResult); NEXT_INST_F(0, 2, 1); + } - /* - * End of INST_LIST and related instructions. - * ----------------------------------------------------------------- - * Start of string-related instructions. - */ + case INST_STR_CMP: + { + /* + * String compare + */ + CONST char *s1, *s2; + int s1len, s2len, iResult; - case INST_STR_EQ: - case INST_STR_NEQ: /* String (in)equality check */ - case INST_STR_CMP: /* String compare. */ - stringCompare: - value2Ptr = OBJ_AT_TOS; - valuePtr = OBJ_UNDER_TOS; + value2Ptr = stackPtr[stackTop]; + valuePtr = stackPtr[stackTop - 1]; + /* + * The comparison function should compare up to the + * minimum byte length only. + */ if (valuePtr == value2Ptr) { - match = 0; - } else { /* - * We only need to check (in)equality when we have equal length - * strings. We can use memcmp in all (n)eq cases because we - * don't need to worry about lexical LE/BE variance. + * In the pure equality case, set lengths too for + * the checks below (or we could goto beyond it). + */ + iResult = s1len = s2len = 0; + } else if ((valuePtr->typePtr == &tclByteArrayType) + && (value2Ptr->typePtr == &tclByteArrayType)) { + s1 = (char *) Tcl_GetByteArrayFromObj(valuePtr, &s1len); + s2 = (char *) Tcl_GetByteArrayFromObj(value2Ptr, &s2len); + iResult = memcmp(s1, s2, + (size_t) ((s1len < s2len) ? s1len : s2len)); + } else if (((valuePtr->typePtr == &tclStringType) + && (value2Ptr->typePtr == &tclStringType))) { + /* + * Do a unicode-specific comparison if both of the args are of + * String type. If the char length == byte length, we can do a + * memcmp. In benchmark testing this proved the most efficient + * check between the unicode and string comparison operations. */ - typedef int (*memCmpFn_t)(const void*, const void*, size_t); - memCmpFn_t memCmpFn; - int checkEq = ((*pc == INST_EQ) || (*pc == INST_NEQ) - || (*pc == INST_STR_EQ) || (*pc == INST_STR_NEQ)); - - if (TclIsPureByteArray(valuePtr) - && TclIsPureByteArray(value2Ptr)) { - s1 = (char *) Tcl_GetByteArrayFromObj(valuePtr, &s1len); - s2 = (char *) Tcl_GetByteArrayFromObj(value2Ptr, &s2len); - memCmpFn = memcmp; - } else if (((valuePtr->typePtr == &tclStringType) - && (value2Ptr->typePtr == &tclStringType))) { - /* - * Do a unicode-specific comparison if both of the args are of - * String type. If the char length == byte length, we can do a - * memcmp. In benchmark testing this proved the most efficient - * check between the unicode and string comparison operations. - */ - - s1len = Tcl_GetCharLength(valuePtr); - s2len = Tcl_GetCharLength(value2Ptr); - if ((s1len == valuePtr->length) - && (s2len == value2Ptr->length)) { - s1 = valuePtr->bytes; - s2 = value2Ptr->bytes; - memCmpFn = memcmp; - } else { - s1 = (char *) Tcl_GetUnicode(valuePtr); - s2 = (char *) Tcl_GetUnicode(value2Ptr); - if ( -#ifdef WORDS_BIGENDIAN - 1 -#else - checkEq -#endif - ) { - memCmpFn = memcmp; - s1len *= sizeof(Tcl_UniChar); - s2len *= sizeof(Tcl_UniChar); - } else { - memCmpFn = (memCmpFn_t) Tcl_UniCharNcmp; - } - } - } else { - /* - * strcmp can't do a simple memcmp in order to handle the - * special Tcl \xC0\x80 null encoding for utf-8. - */ - - s1 = TclGetStringFromObj(valuePtr, &s1len); - s2 = TclGetStringFromObj(value2Ptr, &s2len); - if (checkEq) { - memCmpFn = memcmp; - } else { - memCmpFn = (memCmpFn_t) TclpUtfNcmp2; - } - } - - if (checkEq && (s1len != s2len)) { - match = 1; + s1len = Tcl_GetCharLength(valuePtr); + s2len = Tcl_GetCharLength(value2Ptr); + if ((s1len == valuePtr->length) && (s2len == value2Ptr->length)) { + iResult = memcmp(valuePtr->bytes, value2Ptr->bytes, + (unsigned) ((s1len < s2len) ? s1len : s2len)); } else { - /* - * The comparison function should compare up to the minimum - * byte length only. - */ - match = memCmpFn(s1, s2, - (size_t) ((s1len < s2len) ? s1len : s2len)); - if (match == 0) { - match = s1len - s2len; - } + iResult = TclUniCharNcmp(Tcl_GetUnicode(valuePtr), + Tcl_GetUnicode(value2Ptr), + (unsigned) ((s1len < s2len) ? s1len : s2len)); } + } else { + /* + * We can't do a simple memcmp in order to handle the + * special Tcl \xC0\x80 null encoding for utf-8. + */ + s1 = Tcl_GetStringFromObj(valuePtr, &s1len); + s2 = Tcl_GetStringFromObj(value2Ptr, &s2len); + iResult = TclpUtfNcmp2(s1, s2, + (size_t) ((s1len < s2len) ? s1len : s2len)); } /* * Make sure only -1,0,1 is returned - * TODO: consider peephole opt. */ - - if (*pc != INST_STR_CMP) { - /* - * Take care of the opcodes that goto'ed into here. - */ - - switch (*pc) { - case INST_STR_EQ: - case INST_EQ: - match = (match == 0); - break; - case INST_STR_NEQ: - case INST_NEQ: - match = (match != 0); - break; - case INST_LT: - match = (match < 0); - break; - case INST_GT: - match = (match > 0); - break; - case INST_LE: - match = (match <= 0); - break; - case INST_GE: - match = (match >= 0); - break; - } + if (iResult == 0) { + iResult = s1len - s2len; } - if (match < 0) { - TclNewIntObj(objResultPtr, -1); - } else { - objResultPtr = TCONST(match > 0); + if (iResult < 0) { + iResult = -1; + } else if (iResult > 0) { + iResult = 1; } - TRACE(("%.20s %.20s => %s\n", O2S(valuePtr), O2S(value2Ptr), - O2S(objResultPtr))); + + objResultPtr = Tcl_NewIntObj(iResult); + TRACE(("%.20s %.20s => %d\n", O2S(valuePtr), O2S(value2Ptr), iResult)); NEXT_INST_F(1, 2, 1); + } case INST_STR_LEN: - valuePtr = OBJ_AT_TOS; - length = Tcl_GetCharLength(valuePtr); - TclNewIntObj(objResultPtr, length); - TRACE(("%.20s => %d\n", O2S(valuePtr), length)); - NEXT_INST_F(1, 1, 1); + { + int length1; + + valuePtr = stackPtr[stackTop]; + if (valuePtr->typePtr == &tclByteArrayType) { + (void) Tcl_GetByteArrayFromObj(valuePtr, &length1); + } else { + length1 = Tcl_GetCharLength(valuePtr); + } + objResultPtr = Tcl_NewIntObj(length1); + TRACE(("%.20s => %d\n", O2S(valuePtr), length1)); + NEXT_INST_F(1, 1, 1); + } + case INST_STR_INDEX: - value2Ptr = OBJ_AT_TOS; - valuePtr = OBJ_UNDER_TOS; - + { /* - * Get char length to calulate what 'end' means. + * String compare */ + int index; + bytes = NULL; /* lint */ - length = Tcl_GetCharLength(valuePtr); - if (TclGetIntForIndexM(interp, value2Ptr, length-1, &index)!=TCL_OK) { - goto gotError; - } + value2Ptr = stackPtr[stackTop]; + valuePtr = stackPtr[stackTop - 1]; - if ((index < 0) || (index >= length)) { - TclNewObj(objResultPtr); - } else if (TclIsPureByteArray(valuePtr)) { - objResultPtr = Tcl_NewByteArrayObj( - Tcl_GetByteArrayFromObj(valuePtr, &length)+index, 1); - } else if (valuePtr->bytes && length == valuePtr->length) { - objResultPtr = Tcl_NewStringObj((const char *) - valuePtr->bytes+index, 1); - } else { - char buf[TCL_UTF_MAX]; - Tcl_UniChar ch = Tcl_GetUniChar(valuePtr, index); + /* + * If we have a ByteArray object, avoid indexing in the + * Utf string since the byte array contains one byte per + * character. Otherwise, use the Unicode string rep to + * get the index'th char. + */ + if (valuePtr->typePtr == &tclByteArrayType) { + bytes = (char *)Tcl_GetByteArrayFromObj(valuePtr, &length); + } else { /* - * This could be: Tcl_NewUnicodeObj((const Tcl_UniChar *)&ch, 1) - * but creating the object as a string seems to be faster in - * practical use. + * Get Unicode char length to calulate what 'end' means. */ + length = Tcl_GetCharLength(valuePtr); + } - length = Tcl_UniCharToUtf(ch, buf); - objResultPtr = Tcl_NewStringObj(buf, length); + result = TclGetIntForIndex(interp, value2Ptr, length - 1, &index); + if (result != TCL_OK) { + goto checkForCatch; + } + + if ((index >= 0) && (index < length)) { + if (valuePtr->typePtr == &tclByteArrayType) { + objResultPtr = Tcl_NewByteArrayObj((unsigned char *) + (&bytes[index]), 1); + } else if (valuePtr->bytes && length == valuePtr->length) { + objResultPtr = Tcl_NewStringObj((CONST char *) + (&valuePtr->bytes[index]), 1); + } else { + char buf[TCL_UTF_MAX]; + Tcl_UniChar ch; + + ch = Tcl_GetUniChar(valuePtr, index); + /* + * This could be: + * Tcl_NewUnicodeObj((CONST Tcl_UniChar *)&ch, 1) + * but creating the object as a string seems to be + * faster in practical use. + */ + length = Tcl_UniCharToUtf(ch, buf); + objResultPtr = Tcl_NewStringObj(buf, length); + } + } else { + TclNewObj(objResultPtr); } - TRACE(("%.20s %.20s => %s\n", O2S(valuePtr), O2S(value2Ptr), - O2S(objResultPtr))); + TRACE(("%.20s %.20s => %s\n", O2S(valuePtr), O2S(value2Ptr), + O2S(objResultPtr))); NEXT_INST_F(1, 2, 1); + } case INST_STR_MATCH: - nocase = TclGetInt1AtPtr(pc+1); - valuePtr = OBJ_AT_TOS; /* String */ - value2Ptr = OBJ_UNDER_TOS; /* Pattern */ + { + int nocase, match; + + nocase = TclGetInt1AtPtr(pc+1); + valuePtr = stackPtr[stackTop]; /* String */ + value2Ptr = stackPtr[stackTop - 1]; /* Pattern */ /* - * Check that at least one of the objects is Unicode before promoting - * both. + * Check that at least one of the objects is Unicode before + * promoting both. */ if ((valuePtr->typePtr == &tclStringType) - || (value2Ptr->typePtr == &tclStringType)) { + || (value2Ptr->typePtr == &tclStringType)) { Tcl_UniChar *ustring1, *ustring2; + int length1, length2; - ustring1 = Tcl_GetUnicodeFromObj(valuePtr, &length); + ustring1 = Tcl_GetUnicodeFromObj(valuePtr, &length1); ustring2 = Tcl_GetUnicodeFromObj(value2Ptr, &length2); - match = TclUniCharMatch(ustring1, length, ustring2, length2, + match = TclUniCharMatch(ustring1, length1, ustring2, length2, nocase); - } else if (TclIsPureByteArray(valuePtr) && !nocase) { - unsigned char *bytes1, *bytes2; - - bytes1 = Tcl_GetByteArrayFromObj(valuePtr, &length); - bytes2 = Tcl_GetByteArrayFromObj(value2Ptr, &length2); - match = TclByteArrayMatch(bytes1, length, bytes2, length2, 0); } else { match = Tcl_StringCaseMatch(TclGetString(valuePtr), TclGetString(value2Ptr), nocase); } /* - * Reuse value2Ptr object already on stack if possible. Adjustment is - * 2 due to the nocase byte + * Reuse value2Ptr object already on stack if possible. + * Adjustment is 2 due to the nocase byte */ TRACE(("%.20s %.20s => %d\n", O2S(valuePtr), O2S(value2Ptr), match)); + if (Tcl_IsShared(value2Ptr)) { + objResultPtr = Tcl_NewIntObj(match); + NEXT_INST_F(2, 2, 1); + } else { /* reuse the valuePtr object */ + Tcl_SetIntObj(value2Ptr, match); + NEXT_INST_F(2, 1, 0); + } + } + case INST_EQ: + case INST_NEQ: + case INST_LT: + case INST_GT: + case INST_LE: + case INST_GE: + { /* - * Peep-hole optimisation: if you're about to jump, do jump from here. + * Any type is allowed but the two operands must have the + * same type. We will compute value op value2. */ - pc += 2; -#ifndef TCL_COMPILE_DEBUG - switch (*pc) { - case INST_JUMP_FALSE1: - NEXT_INST_F((match? 2 : TclGetInt1AtPtr(pc+1)), 2, 0); - case INST_JUMP_TRUE1: - NEXT_INST_F((match? TclGetInt1AtPtr(pc+1) : 2), 2, 0); - case INST_JUMP_FALSE4: - NEXT_INST_F((match? 5 : TclGetInt4AtPtr(pc+1)), 2, 0); - case INST_JUMP_TRUE4: - NEXT_INST_F((match? TclGetInt4AtPtr(pc+1) : 5), 2, 0); - } -#endif - objResultPtr = TCONST(match); - NEXT_INST_F(0, 2, 1); + 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. */ - case INST_REGEXP: - cflags = TclGetInt1AtPtr(pc+1); /* RE compile flages like NOCASE */ - valuePtr = OBJ_AT_TOS; /* String */ - value2Ptr = OBJ_UNDER_TOS; /* Pattern */ + value2Ptr = stackPtr[stackTop]; + valuePtr = stackPtr[stackTop - 1]; /* - * Compile and match the regular expression. + * Be careful in the equal-object case; 'NaN' isn't supposed + * to be equal to even itself. [Bug 761471] */ - { - Tcl_RegExp regExpr = - Tcl_GetRegExpFromObj(interp, value2Ptr, cflags); + t1Ptr = valuePtr->typePtr; + if (valuePtr == value2Ptr) { + /* + * If we are numeric already, we can proceed to the main + * equality check right now. Otherwise, we need to try to + * coerce to a numeric type so we can see if we've got a + * NaN but haven't parsed it as numeric. + */ + if (!IS_NUMERIC_TYPE(t1Ptr)) { + if (t1Ptr == &tclListType) { + int length; + /* + * Only a list of length 1 can be NaN or such + * things. + */ + (void) Tcl_ListObjLength(NULL, valuePtr, &length); + if (length == 1) { + goto mustConvertForNaNCheck; + } + } else { + /* + * Too bad, we'll have to compute the string and + * try the conversion + */ - if (regExpr == NULL) { - goto regexpFailure; + mustConvertForNaNCheck: + s1 = Tcl_GetStringFromObj(valuePtr, &length); + if (TclLooksLikeInt(s1, length)) { + GET_WIDE_OR_INT(iResult, valuePtr, i, w); + } else { + (void) Tcl_GetDoubleFromObj((Tcl_Interp *) NULL, + valuePtr, &d1); + } + t1Ptr = valuePtr->typePtr; + } } - match = Tcl_RegExpExecObj(interp, regExpr, valuePtr, 0, 0, 0); - - if (match < 0) { - regexpFailure: -#ifdef TCL_COMPILE_DEBUG - objResultPtr = Tcl_GetObjResult(interp); - TRACE_WITH_OBJ(("%.20s %.20s => ERROR: ", - O2S(valuePtr), O2S(value2Ptr)), objResultPtr); -#endif - goto gotError; + switch (*pc) { + case INST_EQ: + case INST_LE: + case INST_GE: + iResult = !((t1Ptr == &tclDoubleType) + && IS_NAN(valuePtr->internalRep.doubleValue)); + break; + case INST_LT: + case INST_GT: + iResult = 0; + break; + case INST_NEQ: + iResult = ((t1Ptr == &tclDoubleType) + && IS_NAN(valuePtr->internalRep.doubleValue)); + break; } + goto foundResult; } - TRACE(("%.20s %.20s => %d\n", O2S(valuePtr), O2S(value2Ptr), match)); + t2Ptr = value2Ptr->typePtr; /* - * Peep-hole optimisation: if you're about to jump, do jump from here. - * Adjustment is 2 due to the nocase byte. + * We only want to coerce numeric validation if neither type + * is NULL. A NULL type means the arg is essentially an empty + * object ("", {} or [list]). */ - - pc += 2; -#ifndef TCL_COMPILE_DEBUG - switch (*pc) { - case INST_JUMP_FALSE1: - NEXT_INST_F((match? 2 : TclGetInt1AtPtr(pc+1)), 2, 0); - case INST_JUMP_TRUE1: - NEXT_INST_F((match? TclGetInt1AtPtr(pc+1) : 2), 2, 0); - case INST_JUMP_FALSE4: - NEXT_INST_F((match? 5 : TclGetInt4AtPtr(pc+1)), 2, 0); - case INST_JUMP_TRUE4: - NEXT_INST_F((match? TclGetInt4AtPtr(pc+1) : 5), 2, 0); + if (!( (!t1Ptr && !valuePtr->bytes) + || (valuePtr->bytes && !valuePtr->length) + || (!t2Ptr && !value2Ptr->bytes) + || (value2Ptr->bytes && !value2Ptr->length))) { + if (!IS_NUMERIC_TYPE(t1Ptr)) { + s1 = Tcl_GetStringFromObj(valuePtr, &length); + if (TclLooksLikeInt(s1, length)) { + GET_WIDE_OR_INT(iResult, valuePtr, i, w); + } else { + (void) Tcl_GetDoubleFromObj((Tcl_Interp *) NULL, + valuePtr, &d1); + } + t1Ptr = valuePtr->typePtr; + } + if (!IS_NUMERIC_TYPE(t2Ptr)) { + s2 = Tcl_GetStringFromObj(value2Ptr, &length); + if (TclLooksLikeInt(s2, length)) { + GET_WIDE_OR_INT(iResult, value2Ptr, i2, w); + } else { + (void) Tcl_GetDoubleFromObj((Tcl_Interp *) NULL, + value2Ptr, &d2); + } + t2Ptr = value2Ptr->typePtr; + } } -#endif - objResultPtr = TCONST(match); - NEXT_INST_F(0, 2, 1); - } - - /* - * End of string-related instructions. - * ----------------------------------------------------------------- - * Start of numeric operator instructions. - */ - - { - ClientData ptr1, ptr2; - int type1, type2; - long l1, l2, lResult; - - case INST_EQ: - case INST_NEQ: - case INST_LT: - case INST_GT: - case INST_LE: - case INST_GE: { - int iResult = 0, compare = 0; - - value2Ptr = OBJ_AT_TOS; - valuePtr = OBJ_UNDER_TOS; - - if (GetNumberFromObj(NULL, valuePtr, &ptr1, &type1) != TCL_OK) { + if (!IS_NUMERIC_TYPE(t1Ptr) || !IS_NUMERIC_TYPE(t2Ptr)) { /* - * At least one non-numeric argument - compare as strings. + * One operand is not numeric. Compare as strings. NOTE: + * strcmp is not correct for \x00 < \x01, but that is + * unlikely to occur here. We could use the TclUtfNCmp2 + * to handle this. */ - - goto stringCompare; - } - if (type1 == TCL_NUMBER_NAN) { + int s1len, s2len; + s1 = Tcl_GetStringFromObj(valuePtr, &s1len); + s2 = Tcl_GetStringFromObj(value2Ptr, &s2len); + switch (*pc) { + case INST_EQ: + if (s1len == s2len) { + iResult = (strcmp(s1, s2) == 0); + } else { + iResult = 0; + } + break; + case INST_NEQ: + if (s1len == s2len) { + iResult = (strcmp(s1, s2) != 0); + } else { + iResult = 1; + } + break; + case INST_LT: + iResult = (strcmp(s1, s2) < 0); + break; + case INST_GT: + iResult = (strcmp(s1, s2) > 0); + break; + case INST_LE: + iResult = (strcmp(s1, s2) <= 0); + break; + case INST_GE: + iResult = (strcmp(s1, s2) >= 0); + break; + } + } else if ((t1Ptr == &tclDoubleType) + || (t2Ptr == &tclDoubleType)) { /* - * NaN first arg: NaN != to everything, other compares are false. + * Compare as doubles. */ - - iResult = (*pc == INST_NEQ); - goto foundResult; - } - if (valuePtr == value2Ptr) { - compare = MP_EQ; - goto convertComparison; - } - if (GetNumberFromObj(NULL, value2Ptr, &ptr2, &type2) != TCL_OK) { + if (t1Ptr == &tclDoubleType) { + d1 = valuePtr->internalRep.doubleValue; + GET_DOUBLE_VALUE(d2, value2Ptr, t2Ptr); + } else { /* t1Ptr is integer, t2Ptr is double */ + GET_DOUBLE_VALUE(d1, valuePtr, t1Ptr); + d2 = value2Ptr->internalRep.doubleValue; + } + switch (*pc) { + 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 if ((t1Ptr == &tclWideIntType) + || (t2Ptr == &tclWideIntType)) { + Tcl_WideInt w2; /* - * At least one non-numeric argument - compare as strings. + * Compare as wide ints (neither are doubles) */ - - goto stringCompare; - } - if (type2 == TCL_NUMBER_NAN) { + if (t1Ptr == &tclIntType) { + w = Tcl_LongAsWide(valuePtr->internalRep.longValue); + TclGetWide(w2,value2Ptr); + } else if (t2Ptr == &tclIntType) { + TclGetWide(w,valuePtr); + w2 = Tcl_LongAsWide(value2Ptr->internalRep.longValue); + } else { + TclGetWide(w,valuePtr); + TclGetWide(w2,value2Ptr); + } + switch (*pc) { + case INST_EQ: + iResult = w == w2; + break; + case INST_NEQ: + iResult = w != w2; + break; + case INST_LT: + iResult = w < w2; + break; + case INST_GT: + iResult = w > w2; + break; + case INST_LE: + iResult = w <= w2; + break; + case INST_GE: + iResult = w >= w2; + break; + } + } else { /* - * NaN 2nd arg: NaN != to everything, other compares are false. + * Compare as ints. */ - - iResult = (*pc == INST_NEQ); - goto foundResult; - } - if ((type1 == TCL_NUMBER_LONG) && (type2 == TCL_NUMBER_LONG)) { - l1 = *((const long *)ptr1); - l2 = *((const long *)ptr2); - compare = (l1 < l2) ? MP_LT : ((l1 > l2) ? MP_GT : MP_EQ); - } else { - compare = TclCompareTwoNumbers(valuePtr, value2Ptr); + i = valuePtr->internalRep.longValue; + i2 = value2Ptr->internalRep.longValue; + switch (*pc) { + 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; + } } - /* - * Turn comparison outcome into appropriate result for opcode. - */ - - convertComparison: - switch (*pc) { - case INST_EQ: - iResult = (compare == MP_EQ); - break; - case INST_NEQ: - iResult = (compare != MP_EQ); - break; - case INST_LT: - iResult = (compare == MP_LT); - break; - case INST_GT: - iResult = (compare == MP_GT); - break; - case INST_LE: - iResult = (compare != MP_GT); - break; - case INST_GE: - iResult = (compare != MP_LT); - break; - } + foundResult: + TRACE(("%.20s %.20s => %ld\n", O2S(valuePtr), O2S(value2Ptr), iResult)); /* - * Peep-hole optimisation: if you're about to jump, do jump from here. + * Peep-hole optimisation: if you're about to jump, do jump + * from here. */ - foundResult: pc++; #ifndef TCL_COMPILE_DEBUG switch (*pc) { - case INST_JUMP_FALSE1: - NEXT_INST_F((iResult? 2 : TclGetInt1AtPtr(pc+1)), 2, 0); - case INST_JUMP_TRUE1: - NEXT_INST_F((iResult? TclGetInt1AtPtr(pc+1) : 2), 2, 0); - case INST_JUMP_FALSE4: - NEXT_INST_F((iResult? 5 : TclGetInt4AtPtr(pc+1)), 2, 0); - case INST_JUMP_TRUE4: - NEXT_INST_F((iResult? TclGetInt4AtPtr(pc+1) : 5), 2, 0); + case INST_JUMP_FALSE1: + NEXT_INST_F((iResult? 2 : TclGetInt1AtPtr(pc+1)), 2, 0); + case INST_JUMP_TRUE1: + NEXT_INST_F((iResult? TclGetInt1AtPtr(pc+1) : 2), 2, 0); + case INST_JUMP_FALSE4: + NEXT_INST_F((iResult? 5 : TclGetInt4AtPtr(pc+1)), 2, 0); + case INST_JUMP_TRUE4: + NEXT_INST_F((iResult? TclGetInt4AtPtr(pc+1) : 5), 2, 0); } #endif - objResultPtr = TCONST(iResult); + objResultPtr = Tcl_NewIntObj(iResult); NEXT_INST_F(0, 2, 1); } @@ -4820,3049 +3163,1372 @@ TEBCresume( case INST_BITOR: case INST_BITXOR: case INST_BITAND: - value2Ptr = OBJ_AT_TOS; - valuePtr = OBJ_UNDER_TOS; - - if ((GetNumberFromObj(NULL, valuePtr, &ptr1, &type1) != TCL_OK) - || (type1==TCL_NUMBER_DOUBLE) || (type1==TCL_NUMBER_NAN)) { - TRACE(("%.20s %.20s => ILLEGAL 1st TYPE %s\n", O2S(valuePtr), - O2S(value2Ptr), (valuePtr->typePtr? - valuePtr->typePtr->name : "null"))); - DECACHE_STACK_INFO(); - IllegalExprOperandType(interp, pc, valuePtr); - CACHE_STACK_INFO(); - goto gotError; - } - - if ((GetNumberFromObj(NULL, value2Ptr, &ptr2, &type2) != TCL_OK) - || (type2==TCL_NUMBER_DOUBLE) || (type2==TCL_NUMBER_NAN)) { - TRACE(("%.20s %.20s => ILLEGAL 2nd TYPE %s\n", O2S(valuePtr), - O2S(value2Ptr), (value2Ptr->typePtr? - value2Ptr->typePtr->name : "null"))); - DECACHE_STACK_INFO(); - IllegalExprOperandType(interp, pc, value2Ptr); - CACHE_STACK_INFO(); - goto gotError; - } - + { /* - * Check for common, simple case. + * Only integers are allowed. We compute value op value2. */ - if ((type1 == TCL_NUMBER_LONG) && (type2 == TCL_NUMBER_LONG)) { - l1 = *((const long *)ptr1); - l2 = *((const long *)ptr2); - - switch (*pc) { - case INST_MOD: - if (l2 == 0) { - TRACE(("%s %s => DIVIDE BY ZERO\n", O2S(valuePtr), - O2S(value2Ptr))); - goto divideByZero; - } else if ((l2 == 1) || (l2 == -1)) { - /* - * Div. by |1| always yields remainder of 0. - */ - - TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); - objResultPtr = TCONST(0); - TRACE(("%s\n", O2S(objResultPtr))); - NEXT_INST_F(1, 2, 1); - } else if (l1 == 0) { - /* - * 0 % (non-zero) always yields remainder of 0. - */ + long i2 = 0, rem, negative; + long iResult = 0; /* Init. avoids compiler warning. */ + Tcl_WideInt w2, wResult = W0; + int doWide = 0; + + value2Ptr = stackPtr[stackTop]; + valuePtr = stackPtr[stackTop - 1]; + if (valuePtr->typePtr == &tclIntType) { + i = valuePtr->internalRep.longValue; + } else if (valuePtr->typePtr == &tclWideIntType) { + TclGetWide(w,valuePtr); + } else { /* try to convert to int */ + REQUIRE_WIDE_OR_INT(result, valuePtr, i, w); + if (result != TCL_OK) { + TRACE(("%.20s %.20s => ILLEGAL 1st TYPE %s\n", + O2S(valuePtr), O2S(value2Ptr), + (valuePtr->typePtr? + valuePtr->typePtr->name : "null"))); + DECACHE_STACK_INFO(); + IllegalExprOperandType(interp, pc, valuePtr); + CACHE_STACK_INFO(); + goto checkForCatch; + } + } + if (value2Ptr->typePtr == &tclIntType) { + i2 = value2Ptr->internalRep.longValue; + } else if (value2Ptr->typePtr == &tclWideIntType) { + TclGetWide(w2,value2Ptr); + } else { + REQUIRE_WIDE_OR_INT(result, value2Ptr, i2, w2); + if (result != TCL_OK) { + TRACE(("%.20s %.20s => ILLEGAL 2nd TYPE %s\n", + O2S(valuePtr), O2S(value2Ptr), + (value2Ptr->typePtr? + value2Ptr->typePtr->name : "null"))); + DECACHE_STACK_INFO(); + IllegalExprOperandType(interp, pc, value2Ptr); + CACHE_STACK_INFO(); + goto checkForCatch; + } + } - TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); - objResultPtr = TCONST(0); - TRACE(("%s\n", O2S(objResultPtr))); - NEXT_INST_F(1, 2, 1); + switch (*pc) { + 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 (value2Ptr->typePtr == &tclWideIntType && w2 == W0) { + if (valuePtr->typePtr == &tclIntType) { + TRACE(("%ld "LLD" => DIVIDE BY ZERO\n", i, w2)); } else { - lResult = l1 / l2; - - /* - * Force Tcl's integer division rules. - * TODO: examine for logic simplification - */ - - if ((lResult < 0 || (lResult == 0 && - ((l1 < 0 && l2 > 0) || (l1 > 0 && l2 < 0)))) && - (lResult * l2 != l1)) { - lResult -= 1; - } - lResult = l1 - l2*lResult; - goto longResultOfArithmetic; + TRACE((LLD" "LLD" => DIVIDE BY ZERO\n", w, w2)); } - - case INST_RSHIFT: - if (l2 < 0) { - Tcl_SetResult(interp, "negative shift argument", - TCL_STATIC); -#if 0 - DECACHE_STACK_INFO(); - Tcl_SetErrorCode(interp, "ARITH", "DOMAIN", - "domain error: argument not in valid range", - NULL); - CACHE_STACK_INFO(); -#endif - goto gotError; - } else if (l1 == 0) { - TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); - objResultPtr = TCONST(0); - TRACE(("%s\n", O2S(objResultPtr))); - NEXT_INST_F(1, 2, 1); + goto divideByZero; + } + if (value2Ptr->typePtr == &tclIntType && i2 == 0) { + if (valuePtr->typePtr == &tclIntType) { + TRACE(("%ld %ld => DIVIDE BY ZERO\n", i, i2)); } else { - /* - * Quickly force large right shifts to 0 or -1. - */ - - if (l2 >= (long)(CHAR_BIT*sizeof(long))) { - /* - * We assume that INT_MAX is much larger than the - * number of bits in a long. This is a pretty safe - * assumption, given that the former is usually around - * 4e9 and the latter 32 or 64... - */ - - TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); - if (l1 > 0L) { - objResultPtr = TCONST(0); - } else { - TclNewIntObj(objResultPtr, -1); - } - TRACE(("%s\n", O2S(objResultPtr))); - NEXT_INST_F(1, 2, 1); - } - - /* - * Handle shifts within the native long range. - */ - - lResult = l1 >> ((int) l2); - goto longResultOfArithmetic; + TRACE((LLD" %ld => DIVIDE BY ZERO\n", w, i2)); } - - case INST_LSHIFT: - if (l2 < 0) { - Tcl_SetResult(interp, "negative shift argument", - TCL_STATIC); -#if 0 - DECACHE_STACK_INFO(); - Tcl_SetErrorCode(interp, "ARITH", "DOMAIN", - "domain error: argument not in valid range", - NULL); - CACHE_STACK_INFO(); -#endif - goto gotError; - } else if (l1 == 0) { - TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); - objResultPtr = TCONST(0); - TRACE(("%s\n", O2S(objResultPtr))); - NEXT_INST_F(1, 2, 1); - } else if (l2 > (long) INT_MAX) { - /* - * Technically, we could hold the value (1 << (INT_MAX+1)) - * in an mp_int, but since we're using mp_mul_2d() to do - * the work, and it takes only an int argument, that's a - * good place to draw the line. - */ - - Tcl_SetResult(interp, - "integer value too large to represent", - TCL_STATIC); -#if 0 - DECACHE_STACK_INFO(); - Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", - "integer value too large to represent", NULL); - CACHE_STACK_INFO(); -#endif - goto gotError; + goto divideByZero; + } + negative = 0; + if (valuePtr->typePtr == &tclWideIntType + || value2Ptr->typePtr == &tclWideIntType) { + Tcl_WideInt wRemainder; + /* + * Promote to wide + */ + if (valuePtr->typePtr == &tclIntType) { + w = Tcl_LongAsWide(i); + } else if (value2Ptr->typePtr == &tclIntType) { + w2 = Tcl_LongAsWide(i2); + } + if (w2 < 0) { + w2 = -w2; + w = -w; + negative = 1; + } + wRemainder = w % w2; + if (wRemainder < 0) { + wRemainder += w2; + } + if (negative) { + wRemainder = -wRemainder; + } + wResult = wRemainder; + doWide = 1; + break; + } + 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: + /* + * Shifts are never usefully 64-bits wide! + */ + FORCE_LONG(value2Ptr, i2, w2); + if (valuePtr->typePtr == &tclWideIntType) { +#ifdef TCL_COMPILE_DEBUG + w2 = Tcl_LongAsWide(i2); +#endif /* TCL_COMPILE_DEBUG */ + wResult = w; + /* + * Shift in steps when the shift gets large to prevent + * annoying compiler/processor bugs. [Bug 868467] + */ + if (i2 >= 64) { + wResult = Tcl_LongAsWide(0); + } else if (i2 > 60) { + wResult = w << 30; + wResult <<= 30; + wResult <<= i2-60; + } else if (i2 > 30) { + wResult = w << 30; + wResult <<= i2-30; } else { - int shift = (int) l2; - - /* - * Handle shifts within the native long range. - */ - - if ((size_t) shift < CHAR_BIT*sizeof(long) && (l1 != 0) - && !((l1>0 ? l1 : ~l1) & - -(1L<<(CHAR_BIT*sizeof(long) - 1 - shift)))) { - lResult = l1 << shift; - goto longResultOfArithmetic; - } + wResult = w << i2; + } + doWide = 1; + break; + } + /* + * Shift in steps when the shift gets large to prevent + * annoying compiler/processor bugs. [Bug 868467] + */ + if (i2 >= 64) { + iResult = 0; + } else if (i2 > 60) { + iResult = i << 30; + iResult <<= 30; + iResult <<= i2-60; + } else if (i2 > 30) { + iResult = i << 30; + iResult <<= i2-30; + } else { + 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. + */ + /* + * Shifts are never usefully 64-bits wide! + */ + FORCE_LONG(value2Ptr, i2, w2); + if (valuePtr->typePtr == &tclWideIntType) { +#ifdef TCL_COMPILE_DEBUG + w2 = Tcl_LongAsWide(i2); +#endif /* TCL_COMPILE_DEBUG */ + if (w < 0) { + wResult = ~w; + } else { + wResult = w; } - /* - * Too large; need to use the broken-out function. + * Shift in steps when the shift gets large to prevent + * annoying compiler/processor bugs. [Bug 868467] */ - - TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); + if (i2 >= 64) { + wResult = Tcl_LongAsWide(0); + } else if (i2 > 60) { + wResult >>= 30; + wResult >>= 30; + wResult >>= i2-60; + } else if (i2 > 30) { + wResult >>= 30; + wResult >>= i2-30; + } else { + wResult >>= i2; + } + if (w < 0) { + wResult = ~wResult; + } + doWide = 1; break; - - case INST_BITAND: - lResult = l1 & l2; - goto longResultOfArithmetic; - case INST_BITOR: - lResult = l1 | l2; - goto longResultOfArithmetic; - case INST_BITXOR: - lResult = l1 ^ l2; - longResultOfArithmetic: - TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); - if (Tcl_IsShared(valuePtr)) { - TclNewLongObj(objResultPtr, lResult); - TRACE(("%s\n", O2S(objResultPtr))); - NEXT_INST_F(1, 2, 1); + } + if (i < 0) { + iResult = ~i; + } else { + iResult = i; + } + /* + * Shift in steps when the shift gets large to prevent + * annoying compiler/processor bugs. [Bug 868467] + */ + if (i2 >= 64) { + iResult = 0; + } else if (i2 > 60) { + iResult >>= 30; + iResult >>= 30; + iResult >>= i2-60; + } else if (i2 > 30) { + iResult >>= 30; + iResult >>= i2-30; + } else { + iResult >>= i2; + } + if (i < 0) { + iResult = ~iResult; + } + break; + case INST_BITOR: + if (valuePtr->typePtr == &tclWideIntType + || value2Ptr->typePtr == &tclWideIntType) { + /* + * Promote to wide + */ + if (valuePtr->typePtr == &tclIntType) { + w = Tcl_LongAsWide(i); + } else if (value2Ptr->typePtr == &tclIntType) { + w2 = Tcl_LongAsWide(i2); } - TclSetLongObj(valuePtr, lResult); - TRACE(("%s\n", O2S(valuePtr))); - NEXT_INST_F(1, 1, 0); + wResult = w | w2; + doWide = 1; + break; } + iResult = i | i2; + break; + case INST_BITXOR: + if (valuePtr->typePtr == &tclWideIntType + || value2Ptr->typePtr == &tclWideIntType) { + /* + * Promote to wide + */ + if (valuePtr->typePtr == &tclIntType) { + w = Tcl_LongAsWide(i); + } else if (value2Ptr->typePtr == &tclIntType) { + w2 = Tcl_LongAsWide(i2); + } + wResult = w ^ w2; + doWide = 1; + break; + } + iResult = i ^ i2; + break; + case INST_BITAND: + if (valuePtr->typePtr == &tclWideIntType + || value2Ptr->typePtr == &tclWideIntType) { + /* + * Promote to wide + */ + if (valuePtr->typePtr == &tclIntType) { + w = Tcl_LongAsWide(i); + } else if (value2Ptr->typePtr == &tclIntType) { + w2 = Tcl_LongAsWide(i2); + } + wResult = w & w2; + doWide = 1; + break; + } + iResult = i & i2; + break; } /* - * DO NOT MERGE THIS WITH THE EQUIVALENT SECTION LATER! That would - * encourage the compiler to inline ExecuteExtendedBinaryMathOp, which - * is highly undesirable due to the overall impact on size. + * Reuse the valuePtr object already on stack if possible. */ - - TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); - objResultPtr = ExecuteExtendedBinaryMathOp(interp, *pc, &TCONST(0), - valuePtr, value2Ptr); - if (objResultPtr == DIVIDED_BY_ZERO) { - TRACE_APPEND(("DIVIDE BY ZERO\n")); - goto divideByZero; - } else if (objResultPtr == GENERAL_ARITHMETIC_ERROR) { - TRACE_APPEND(("ERROR: %s\n", - TclGetString(Tcl_GetObjResult(interp)))); - goto gotError; - } else if (objResultPtr == NULL) { - TRACE_APPEND(("%s\n", O2S(valuePtr))); - NEXT_INST_F(1, 1, 0); - } else { - TRACE_APPEND(("%s\n", O2S(objResultPtr))); + + if (Tcl_IsShared(valuePtr)) { + if (doWide) { + objResultPtr = Tcl_NewWideIntObj(wResult); + TRACE((LLD" "LLD" => "LLD"\n", w, w2, wResult)); + } else { + objResultPtr = Tcl_NewLongObj(iResult); + TRACE(("%ld %ld => %ld\n", i, i2, iResult)); + } NEXT_INST_F(1, 2, 1); + } else { /* reuse the valuePtr object */ + if (doWide) { + TRACE((LLD" "LLD" => "LLD"\n", w, w2, wResult)); + Tcl_SetWideIntObj(valuePtr, wResult); + } else { + TRACE(("%ld %ld => %ld\n", i, i2, iResult)); + Tcl_SetLongObj(valuePtr, iResult); + } + NEXT_INST_F(1, 1, 0); } + } - case INST_EXPON: case INST_ADD: case INST_SUB: - case INST_DIV: case INST_MULT: - value2Ptr = OBJ_AT_TOS; - valuePtr = OBJ_UNDER_TOS; - - if ((GetNumberFromObj(NULL, valuePtr, &ptr1, &type1) != TCL_OK) - || IsErroringNaNType(type1)) { - TRACE(("%.20s %.20s => ILLEGAL 1st TYPE %s\n", - O2S(value2Ptr), O2S(valuePtr), - (valuePtr->typePtr? valuePtr->typePtr->name: "null"))); - DECACHE_STACK_INFO(); - IllegalExprOperandType(interp, pc, valuePtr); - CACHE_STACK_INFO(); - goto gotError; - } + case INST_DIV: + { + /* + * Operands must be numeric and ints get converted to floats + * if necessary. We compute value op value2. + */ -#ifdef ACCEPT_NAN - if (type1 == TCL_NUMBER_NAN) { + Tcl_ObjType *t1Ptr, *t2Ptr; + long i2 = 0, quot, rem; /* Init. avoids compiler warning. */ + 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 */ + Tcl_WideInt w2, wquot, wrem; + Tcl_WideInt wResult = W0; /* Init. avoids compiler warning. */ + int doWide = 0; /* 1 if doing wide arithmetic. */ + + value2Ptr = stackPtr[stackTop]; + valuePtr = stackPtr[stackTop - 1]; + t1Ptr = valuePtr->typePtr; + t2Ptr = value2Ptr->typePtr; + + if (t1Ptr == &tclIntType) { + i = valuePtr->internalRep.longValue; + } else if (t1Ptr == &tclWideIntType) { + TclGetWide(w,valuePtr); + } else if ((t1Ptr == &tclDoubleType) + && (valuePtr->bytes == NULL)) { /* - * NaN first argument -> result is also NaN. + * We can only use the internal rep directly if there is + * no string rep. Otherwise the string rep might actually + * look like an integer, which is preferred. */ - NEXT_INST_F(1, 1, 0); - } -#endif - - if ((GetNumberFromObj(NULL, value2Ptr, &ptr2, &type2) != TCL_OK) - || IsErroringNaNType(type2)) { - TRACE(("%.20s %.20s => ILLEGAL 2nd TYPE %s\n", - O2S(value2Ptr), O2S(valuePtr), - (value2Ptr->typePtr? value2Ptr->typePtr->name: "null"))); - DECACHE_STACK_INFO(); - IllegalExprOperandType(interp, pc, value2Ptr); - CACHE_STACK_INFO(); - goto gotError; + d1 = valuePtr->internalRep.doubleValue; + } else { + char *s = Tcl_GetStringFromObj(valuePtr, &length); + if (TclLooksLikeInt(s, length)) { + GET_WIDE_OR_INT(result, valuePtr, i, w); + } else { + result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL, + valuePtr, &d1); + } + if (result != TCL_OK) { + TRACE(("%.20s %.20s => ILLEGAL 1st TYPE %s\n", + s, O2S(valuePtr), + (valuePtr->typePtr? + valuePtr->typePtr->name : "null"))); + DECACHE_STACK_INFO(); + IllegalExprOperandType(interp, pc, valuePtr); + CACHE_STACK_INFO(); + goto checkForCatch; + } + t1Ptr = valuePtr->typePtr; } -#ifdef ACCEPT_NAN - if (type2 == TCL_NUMBER_NAN) { + if (t2Ptr == &tclIntType) { + i2 = value2Ptr->internalRep.longValue; + } else if (t2Ptr == &tclWideIntType) { + TclGetWide(w2,value2Ptr); + } else if ((t2Ptr == &tclDoubleType) + && (value2Ptr->bytes == NULL)) { /* - * NaN second argument -> result is also NaN. + * We can only use the internal rep directly if there is + * no string rep. Otherwise the string rep might actually + * look like an integer, which is preferred. */ - objResultPtr = value2Ptr; - NEXT_INST_F(1, 2, 1); + d2 = value2Ptr->internalRep.doubleValue; + } else { + char *s = Tcl_GetStringFromObj(value2Ptr, &length); + if (TclLooksLikeInt(s, length)) { + GET_WIDE_OR_INT(result, value2Ptr, i2, w2); + } else { + result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL, + value2Ptr, &d2); + } + if (result != TCL_OK) { + TRACE(("%.20s %.20s => ILLEGAL 2nd TYPE %s\n", + O2S(value2Ptr), s, + (value2Ptr->typePtr? + value2Ptr->typePtr->name : "null"))); + DECACHE_STACK_INFO(); + IllegalExprOperandType(interp, pc, value2Ptr); + CACHE_STACK_INFO(); + goto checkForCatch; + } + t2Ptr = value2Ptr->typePtr; } -#endif - - /* - * Handle (long,long) arithmetic as best we can without going out to - * an external function. - */ - - if ((type1 == TCL_NUMBER_LONG) && (type2 == TCL_NUMBER_LONG)) { - Tcl_WideInt w1, w2, wResult; - - l1 = *((const long *)ptr1); - l2 = *((const long *)ptr2); + 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 */ + } else if (t1Ptr == &tclWideIntType) { + d1 = Tcl_WideAsDouble(w); + } else if (t2Ptr == &tclWideIntType) { + d2 = Tcl_WideAsDouble(w2); + } switch (*pc) { - case INST_ADD: - w1 = (Tcl_WideInt) l1; - w2 = (Tcl_WideInt) l2; - wResult = w1 + w2; -#ifdef NO_WIDE_TYPE - /* - * Check for overflow. - */ - - if (Overflowing(w1, w2, wResult)) { - goto overflow; - } -#endif - goto wideResultOfArithmetic; - - case INST_SUB: - w1 = (Tcl_WideInt) l1; - w2 = (Tcl_WideInt) l2; - wResult = w1 - w2; -#ifdef NO_WIDE_TYPE - /* - * Must check for overflow. The macro tests for overflows in - * sums by looking at the sign bits. As we have a subtraction - * here, we are adding -w2. As -w2 could in turn overflow, we - * test with ~w2 instead: it has the opposite sign bit to w2 - * so it does the job. Note that the only "bad" case (w2==0) - * is irrelevant for this macro, as in that case w1 and - * wResult have the same sign and there is no overflow anyway. - */ - - if (Overflowing(w1, ~w2, wResult)) { - goto overflow; - } -#endif - wideResultOfArithmetic: - TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); - if (Tcl_IsShared(valuePtr)) { - objResultPtr = Tcl_NewWideIntObj(wResult); - TRACE(("%s\n", O2S(objResultPtr))); - NEXT_INST_F(1, 2, 1); - } - Tcl_SetWideIntObj(valuePtr, wResult); - TRACE(("%s\n", O2S(valuePtr))); - NEXT_INST_F(1, 1, 0); - - case INST_DIV: - if (l2 == 0) { - TRACE(("%s %s => DIVIDE BY ZERO\n", - O2S(valuePtr), O2S(value2Ptr))); - goto divideByZero; - } else if ((l1 == LONG_MIN) && (l2 == -1)) { + 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(("%.6g %.6g => DIVIDE BY ZERO\n", d1, d2)); + goto divideByZero; + } + dResult = d1 / d2; + break; + } + + /* + * Check now for IEEE floating-point error. + */ + + if (IS_NAN(dResult) || IS_INF(dResult)) { + TRACE(("%.20s %.20s => IEEE FLOATING PT ERROR\n", + O2S(valuePtr), O2S(value2Ptr))); + DECACHE_STACK_INFO(); + TclExprFloatError(interp, dResult); + CACHE_STACK_INFO(); + result = TCL_ERROR; + goto checkForCatch; + } + } else if ((t1Ptr == &tclWideIntType) + || (t2Ptr == &tclWideIntType)) { + /* + * Do wide integer arithmetic. + */ + doWide = 1; + if (t1Ptr == &tclIntType) { + w = Tcl_LongAsWide(i); + } else if (t2Ptr == &tclIntType) { + w2 = Tcl_LongAsWide(i2); + } + switch (*pc) { + case INST_ADD: + wResult = w + w2; + break; + case INST_SUB: + wResult = w - w2; + break; + case INST_MULT: + wResult = w * w2; + break; + case INST_DIV: /* - * Can't represent (-LONG_MIN) as a long. + * 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. */ - - goto overflow; - } - lResult = l1 / l2; - - /* - * Force Tcl's integer division rules. - * TODO: examine for logic simplification - */ - - if (((lResult < 0) || ((lResult == 0) && - ((l1 < 0 && l2 > 0) || (l1 > 0 && l2 < 0)))) && - ((lResult * l2) != l1)) { - lResult -= 1; - } - goto longResultOfArithmetic; - - case INST_MULT: - if (((sizeof(long) >= 2*sizeof(int)) - && (l1 <= INT_MAX) && (l1 >= INT_MIN) - && (l2 <= INT_MAX) && (l2 >= INT_MIN)) - || ((sizeof(long) >= 2*sizeof(short)) - && (l1 <= SHRT_MAX) && (l1 >= SHRT_MIN) - && (l2 <= SHRT_MAX) && (l2 >= SHRT_MIN))) { - lResult = l1 * l2; - goto longResultOfArithmetic; - } + if (w2 == W0) { + TRACE((LLD" "LLD" => DIVIDE BY ZERO\n", w, w2)); + goto divideByZero; + } + if (w2 < 0) { + w2 = -w2; + w = -w; + } + wquot = w / w2; + wrem = w % w2; + if (wrem < W0) { + wquot -= 1; + } + wResult = wquot; + break; } - + } else { /* - * Fall through with INST_EXPON, INST_DIV and large multiplies. - */ + * Do integer arithmetic. + */ + switch (*pc) { + 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(("%ld %ld => DIVIDE BY ZERO\n", i, i2)); + goto divideByZero; + } + if (i2 < 0) { + i2 = -i2; + i = -i; + } + quot = i / i2; + rem = i % i2; + if (rem < 0) { + quot -= 1; + } + iResult = quot; + break; + } } - overflow: - TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); - objResultPtr = ExecuteExtendedBinaryMathOp(interp, *pc, &TCONST(0), - valuePtr, value2Ptr); - if (objResultPtr == DIVIDED_BY_ZERO) { - TRACE_APPEND(("DIVIDE BY ZERO\n")); - goto divideByZero; - } else if (objResultPtr == EXPONENT_OF_ZERO) { - TRACE_APPEND(("EXPONENT OF ZERO\n")); - goto exponOfZero; - } else if (objResultPtr == GENERAL_ARITHMETIC_ERROR) { - TRACE_APPEND(("ERROR: %s\n", - TclGetString(Tcl_GetObjResult(interp)))); - goto gotError; - } else if (objResultPtr == NULL) { - TRACE_APPEND(("%s\n", O2S(valuePtr))); - NEXT_INST_F(1, 1, 0); - } else { - TRACE_APPEND(("%s\n", O2S(objResultPtr))); + /* + * Reuse the valuePtr object already on stack if possible. + */ + + if (Tcl_IsShared(valuePtr)) { + if (doDouble) { + objResultPtr = Tcl_NewDoubleObj(dResult); + TRACE(("%.6g %.6g => %.6g\n", d1, d2, dResult)); + } else if (doWide) { + objResultPtr = Tcl_NewWideIntObj(wResult); + TRACE((LLD" "LLD" => "LLD"\n", w, w2, wResult)); + } else { + objResultPtr = Tcl_NewLongObj(iResult); + TRACE(("%ld %ld => %ld\n", i, i2, iResult)); + } NEXT_INST_F(1, 2, 1); + } else { /* reuse the valuePtr object */ + if (doDouble) { /* NB: stack top is off by 1 */ + TRACE(("%.6g %.6g => %.6g\n", d1, d2, dResult)); + Tcl_SetDoubleObj(valuePtr, dResult); + } else if (doWide) { + TRACE((LLD" "LLD" => "LLD"\n", w, w2, wResult)); + Tcl_SetWideIntObj(valuePtr, wResult); + } else { + TRACE(("%ld %ld => %ld\n", i, i2, iResult)); + Tcl_SetLongObj(valuePtr, iResult); + } + NEXT_INST_F(1, 1, 0); } + } - case INST_LNOT: { - int b; - - valuePtr = OBJ_AT_TOS; + case INST_UPLUS: + { + /* + * Operand must be numeric. + */ - /* TODO - check claim that taking address of b harms performance */ - /* TODO - consider optimization search for constants */ - if (TclGetBooleanFromObj(NULL, valuePtr, &b) != TCL_OK) { - TRACE(("\"%.20s\" => ILLEGAL TYPE %s\n", O2S(valuePtr), - (valuePtr->typePtr? valuePtr->typePtr->name : "null"))); - DECACHE_STACK_INFO(); - IllegalExprOperandType(interp, pc, valuePtr); - CACHE_STACK_INFO(); - goto gotError; + double d; + Tcl_ObjType *tPtr; + + valuePtr = stackPtr[stackTop]; + tPtr = valuePtr->typePtr; + if (!IS_INTEGER_TYPE(tPtr) && ((tPtr != &tclDoubleType) + || (valuePtr->bytes != NULL))) { + char *s = Tcl_GetStringFromObj(valuePtr, &length); + if (TclLooksLikeInt(s, length)) { + GET_WIDE_OR_INT(result, valuePtr, i, w); + } else { + result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL, valuePtr, &d); + } + if (result != TCL_OK) { + TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", + s, (tPtr? tPtr->name : "null"))); + DECACHE_STACK_INFO(); + IllegalExprOperandType(interp, pc, valuePtr); + CACHE_STACK_INFO(); + goto checkForCatch; + } + tPtr = valuePtr->typePtr; } - /* TODO: Consider peephole opt. */ - objResultPtr = TCONST(!b); - NEXT_INST_F(1, 1, 1); - } - case INST_BITNOT: - valuePtr = OBJ_AT_TOS; - if ((GetNumberFromObj(NULL, valuePtr, &ptr1, &type1) != TCL_OK) - || (type1==TCL_NUMBER_NAN) || (type1==TCL_NUMBER_DOUBLE)) { - /* - * ... ~$NonInteger => raise an error. - */ + /* + * Ensure that the operand's string rep is the same as the + * formatted version of its internal rep. This makes sure + * that "expr +000123" yields "83", not "000123". 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. + */ - TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(valuePtr), - (valuePtr->typePtr? valuePtr->typePtr->name : "null"))); - DECACHE_STACK_INFO(); - IllegalExprOperandType(interp, pc, valuePtr); - CACHE_STACK_INFO(); - goto gotError; - } - if (type1 == TCL_NUMBER_LONG) { - l1 = *((const long *) ptr1); - if (Tcl_IsShared(valuePtr)) { - TclNewLongObj(objResultPtr, ~l1); - NEXT_INST_F(1, 1, 1); + if (Tcl_IsShared(valuePtr)) { + if (tPtr == &tclIntType) { + i = valuePtr->internalRep.longValue; + objResultPtr = Tcl_NewLongObj(i); + } else if (tPtr == &tclWideIntType) { + TclGetWide(w,valuePtr); + objResultPtr = Tcl_NewWideIntObj(w); + } else { + d = valuePtr->internalRep.doubleValue; + objResultPtr = Tcl_NewDoubleObj(d); } - TclSetLongObj(valuePtr, ~l1); - NEXT_INST_F(1, 0, 0); - } - objResultPtr = ExecuteExtendedUnaryMathOp(*pc, valuePtr); - if (objResultPtr != NULL) { + TRACE_WITH_OBJ(("%s => ", O2S(objResultPtr)), objResultPtr); NEXT_INST_F(1, 1, 1); } else { + Tcl_InvalidateStringRep(valuePtr); + TRACE_WITH_OBJ(("%s => ", O2S(valuePtr)), valuePtr); NEXT_INST_F(1, 0, 0); } - + } + case INST_UMINUS: - valuePtr = OBJ_AT_TOS; - if ((GetNumberFromObj(NULL, valuePtr, &ptr1, &type1) != TCL_OK) - || IsErroringNaNType(type1)) { - TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(valuePtr), - (valuePtr->typePtr? valuePtr->typePtr->name : "null"))); - DECACHE_STACK_INFO(); - IllegalExprOperandType(interp, pc, valuePtr); - CACHE_STACK_INFO(); - goto gotError; - } - switch (type1) { - case TCL_NUMBER_NAN: - /* -NaN => NaN */ - NEXT_INST_F(1, 0, 0); - case TCL_NUMBER_LONG: - l1 = *((const long *) ptr1); - if (l1 != LONG_MIN) { - if (Tcl_IsShared(valuePtr)) { - TclNewLongObj(objResultPtr, -l1); - NEXT_INST_F(1, 1, 1); + case INST_LNOT: + { + /* + * The operand must be numeric or a boolean string as + * accepted by Tcl_GetBooleanFromObj(). 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; + int boolvar; + Tcl_ObjType *tPtr; + + valuePtr = stackPtr[stackTop]; + tPtr = valuePtr->typePtr; + if (!IS_INTEGER_TYPE(tPtr) && ((tPtr != &tclDoubleType) + || (valuePtr->bytes != NULL))) { + if ((tPtr == &tclBooleanType) && (valuePtr->bytes == NULL)) { + valuePtr->typePtr = &tclIntType; + } else { + char *s = Tcl_GetStringFromObj(valuePtr, &length); + if (TclLooksLikeInt(s, length)) { + GET_WIDE_OR_INT(result, valuePtr, i, w); + } else { + result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL, + valuePtr, &d); + } + if (result == TCL_ERROR && *pc == INST_LNOT) { + result = Tcl_GetBooleanFromObj((Tcl_Interp *)NULL, + valuePtr, &boolvar); + i = (long)boolvar; /* i is long, not int! */ + } + if (result != TCL_OK) { + TRACE(("\"%.20s\" => ILLEGAL TYPE %s\n", + s, (tPtr? tPtr->name : "null"))); + DECACHE_STACK_INFO(); + IllegalExprOperandType(interp, pc, valuePtr); + CACHE_STACK_INFO(); + goto checkForCatch; } - TclSetLongObj(valuePtr, -l1); - NEXT_INST_F(1, 0, 0); } - /* FALLTHROUGH */ + tPtr = valuePtr->typePtr; } - objResultPtr = ExecuteExtendedUnaryMathOp(*pc, valuePtr); - if (objResultPtr != NULL) { + + if (Tcl_IsShared(valuePtr)) { + /* + * Create a new object. + */ + if ((tPtr == &tclIntType) || (tPtr == &tclBooleanType)) { + i = valuePtr->internalRep.longValue; + objResultPtr = Tcl_NewLongObj( + (*pc == INST_UMINUS)? -i : !i); + TRACE_WITH_OBJ(("%ld => ", i), objResultPtr); + } else if (tPtr == &tclWideIntType) { + TclGetWide(w,valuePtr); + if (*pc == INST_UMINUS) { + objResultPtr = Tcl_NewWideIntObj(-w); + } else { + objResultPtr = Tcl_NewLongObj(w == W0); + } + TRACE_WITH_OBJ((LLD" => ", w), objResultPtr); + } else { + d = valuePtr->internalRep.doubleValue; + if (*pc == INST_UMINUS) { + objResultPtr = Tcl_NewDoubleObj(-d); + } else { + /* + * Should be able to use "!d", but apparently + * some compilers can't handle it. + */ + objResultPtr = Tcl_NewLongObj((d==0.0)? 1 : 0); + } + TRACE_WITH_OBJ(("%.6g => ", d), objResultPtr); + } NEXT_INST_F(1, 1, 1); } else { + /* + * valuePtr is unshared. Modify it directly. + */ + if ((tPtr == &tclIntType) || (tPtr == &tclBooleanType)) { + i = valuePtr->internalRep.longValue; + Tcl_SetLongObj(valuePtr, + (*pc == INST_UMINUS)? -i : !i); + TRACE_WITH_OBJ(("%ld => ", i), valuePtr); + } else if (tPtr == &tclWideIntType) { + TclGetWide(w,valuePtr); + if (*pc == INST_UMINUS) { + Tcl_SetWideIntObj(valuePtr, -w); + } else { + Tcl_SetLongObj(valuePtr, w == W0); + } + TRACE_WITH_OBJ((LLD" => ", w), valuePtr); + } else { + d = valuePtr->internalRep.doubleValue; + if (*pc == 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(("%.6g => ", d), valuePtr); + } NEXT_INST_F(1, 0, 0); } + } - case INST_UPLUS: - case INST_TRY_CVT_TO_NUMERIC: + case INST_BITNOT: + { /* - * Try to convert the topmost stack object to numeric object. This is - * done in order to support [expr]'s policy of interpreting operands - * if at all possible as numbers first, then strings. + * 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. */ - - valuePtr = OBJ_AT_TOS; - - if (GetNumberFromObj(NULL, valuePtr, &ptr1, &type1) != TCL_OK) { - if (*pc == INST_UPLUS) { - /* - * ... +$NonNumeric => raise an error. - */ - - TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(valuePtr), - (valuePtr->typePtr? valuePtr->typePtr->name:"null"))); + + Tcl_ObjType *tPtr; + + valuePtr = stackPtr[stackTop]; + tPtr = valuePtr->typePtr; + if (!IS_INTEGER_TYPE(tPtr)) { + REQUIRE_WIDE_OR_INT(result, valuePtr, i, w); + if (result != TCL_OK) { /* try to convert to double */ + TRACE(("\"%.20s\" => ILLEGAL TYPE %s\n", + O2S(valuePtr), (tPtr? tPtr->name : "null"))); DECACHE_STACK_INFO(); IllegalExprOperandType(interp, pc, valuePtr); CACHE_STACK_INFO(); - goto gotError; + goto checkForCatch; } - - /* ... TryConvertToNumeric($NonNumeric) is acceptable */ - TRACE(("\"%.20s\" => not numeric\n", O2S(valuePtr))); - NEXT_INST_F(1, 0, 0); } - if (IsErroringNaNType(type1)) { - if (*pc == INST_UPLUS) { + + if (valuePtr->typePtr == &tclWideIntType) { + TclGetWide(w,valuePtr); + if (Tcl_IsShared(valuePtr)) { + objResultPtr = Tcl_NewWideIntObj(~w); + TRACE(("0x%" TCL_LL_MODIFIER "x => (%" TCL_LL_MODIFIER "u)\n", + w, ~w)); + NEXT_INST_F(1, 1, 1); + } else { /* - * ... +$NonNumeric => raise an error. + * valuePtr is unshared. Modify it directly. */ - - TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(valuePtr), - (valuePtr->typePtr? valuePtr->typePtr->name:"null"))); - DECACHE_STACK_INFO(); - IllegalExprOperandType(interp, pc, valuePtr); - CACHE_STACK_INFO(); + Tcl_SetWideIntObj(valuePtr, ~w); + TRACE(("0x%" TCL_LL_MODIFIER "x => (%" TCL_LL_MODIFIER "u)\n", + w, ~w)); + NEXT_INST_F(1, 0, 0); + } + } else { + i = valuePtr->internalRep.longValue; + if (Tcl_IsShared(valuePtr)) { + objResultPtr = Tcl_NewLongObj(~i); + TRACE(("0x%lx => (%lu)\n", i, ~i)); + NEXT_INST_F(1, 1, 1); } else { /* - * Numeric conversion of NaN -> error. + * valuePtr is unshared. Modify it directly. */ - - TRACE(("\"%.20s\" => IEEE FLOATING PT ERROR\n", - O2S(objResultPtr))); - DECACHE_STACK_INFO(); - TclExprFloatError(interp, *((const double *) ptr1)); - CACHE_STACK_INFO(); + Tcl_SetLongObj(valuePtr, ~i); + TRACE(("0x%lx => (%lu)\n", i, ~i)); + NEXT_INST_F(1, 0, 0); } - goto gotError; } + } - /* - * Ensure that the numeric value 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. - */ + case INST_CALL_BUILTIN_FUNC1: + opnd = TclGetUInt1AtPtr(pc+1); + { + /* + * Call one of the built-in Tcl math functions. + */ - if (valuePtr->bytes == NULL) { - TRACE(("\"%.20s\" => numeric, same Tcl_Obj\n", O2S(valuePtr))); - NEXT_INST_F(1, 0, 0); + 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 = &(tclBuiltinFuncTable[opnd]); + DECACHE_STACK_INFO(); + result = (*mathFuncPtr->proc)(interp, eePtr, + mathFuncPtr->clientData); + CACHE_STACK_INFO(); + if (result != TCL_OK) { + goto checkForCatch; + } + TRACE_WITH_OBJ(("%d => ", opnd), stackPtr[stackTop]); } - if (Tcl_IsShared(valuePtr)) { + NEXT_INST_F(2, 0, 0); + + case INST_CALL_FUNC1: + opnd = TclGetUInt1AtPtr(pc+1); + { /* - * Here we do some surgery within the Tcl_Obj internals. We want - * to copy the intrep, but not the string, so we temporarily hide - * the string so we do not copy it. + * 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)]); /* "objv[0]" */ + DECACHE_STACK_INFO(); + result = ExprCallMathFunc(interp, eePtr, objc, objv); + CACHE_STACK_INFO(); + if (result != TCL_OK) { + goto checkForCatch; + } + TRACE_WITH_OBJ(("%d => ", objc), stackPtr[stackTop]); + } + NEXT_INST_F(2, 0, 0); - char *savedString = valuePtr->bytes; + 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, needNew; + + valuePtr = stackPtr[stackTop]; + tPtr = valuePtr->typePtr; + converted = 0; + if (!IS_INTEGER_TYPE(tPtr) && ((tPtr != &tclDoubleType) + || (valuePtr->bytes != NULL))) { + if ((tPtr == &tclBooleanType) && (valuePtr->bytes == NULL)) { + valuePtr->typePtr = &tclIntType; + converted = 1; + } else { + s = Tcl_GetStringFromObj(valuePtr, &length); + if (TclLooksLikeInt(s, length)) { + GET_WIDE_OR_INT(result, valuePtr, i, w); + } 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; + } - valuePtr->bytes = NULL; - objResultPtr = Tcl_DuplicateObj(valuePtr); - valuePtr->bytes = savedString; - TRACE(("\"%.20s\" => numeric, new Tcl_Obj\n", O2S(valuePtr))); + /* + * 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. + */ + + objResultPtr = valuePtr; + needNew = 0; + if (IS_NUMERIC_TYPE(tPtr)) { + if (Tcl_IsShared(valuePtr)) { + if (valuePtr->bytes != NULL) { + /* + * We only need to make a copy of the object + * when it already had a string rep + */ + needNew = 1; + if (tPtr == &tclIntType) { + i = valuePtr->internalRep.longValue; + objResultPtr = Tcl_NewLongObj(i); + } else if (tPtr == &tclWideIntType) { + TclGetWide(w,valuePtr); + objResultPtr = Tcl_NewWideIntObj(w); + } else { + d = valuePtr->internalRep.doubleValue; + objResultPtr = Tcl_NewDoubleObj(d); + } + tPtr = objResultPtr->typePtr; + } + } else { + Tcl_InvalidateStringRep(valuePtr); + } + + if (tPtr == &tclDoubleType) { + d = objResultPtr->internalRep.doubleValue; + if (IS_NAN(d) || IS_INF(d)) { + TRACE(("\"%.20s\" => IEEE FLOATING PT ERROR\n", + O2S(objResultPtr))); + DECACHE_STACK_INFO(); + TclExprFloatError(interp, d); + CACHE_STACK_INFO(); + result = TCL_ERROR; + goto checkForCatch; + } + } + converted = converted; /* lint, converted not used. */ + TRACE(("\"%.20s\" => numeric, %s, %s\n", O2S(valuePtr), + (converted? "converted" : "not converted"), + (needNew? "new Tcl_Obj" : "same Tcl_Obj"))); + } else { + TRACE(("\"%.20s\" => not numeric\n", O2S(valuePtr))); + } + if (needNew) { NEXT_INST_F(1, 1, 1); + } else { + NEXT_INST_F(1, 0, 0); } - TclInvalidateStringRep(valuePtr); - TRACE(("\"%.20s\" => numeric, same Tcl_Obj\n", O2S(valuePtr))); - NEXT_INST_F(1, 0, 0); } - - /* - * End of numeric operator instructions. - * ----------------------------------------------------------------- - */ - + case INST_BREAK: - /* DECACHE_STACK_INFO(); Tcl_ResetResult(interp); CACHE_STACK_INFO(); - */ result = TCL_BREAK; cleanup = 0; goto processExceptionReturn; case INST_CONTINUE: - /* DECACHE_STACK_INFO(); Tcl_ResetResult(interp); CACHE_STACK_INFO(); - */ result = TCL_CONTINUE; cleanup = 0; goto processExceptionReturn; - { - ForeachInfo *infoPtr; - Var *iterVarPtr, *listVarPtr; - Tcl_Obj *oldValuePtr, *listPtr, **elements; - ForeachVarList *varListPtr; - int numLists, iterNum, listTmpIndex, listLen, numVars; - int varIndex, valIndex, continueLoop, j, iterTmpIndex; - long i; - case INST_FOREACH_START4: - /* - * Initialize the temporary local var that holds the count of the - * number of iterations of the loop body to -1. - */ - opnd = TclGetUInt4AtPtr(pc+1); - infoPtr = codePtr->auxDataArrayPtr[opnd].clientData; - iterTmpIndex = infoPtr->loopCtTemp; - iterVarPtr = LOCAL(iterTmpIndex); - oldValuePtr = iterVarPtr->value.objPtr; - - if (oldValuePtr == NULL) { - TclNewLongObj(iterVarPtr->value.objPtr, -1); - Tcl_IncrRefCount(iterVarPtr->value.objPtr); - } else { - TclSetLongObj(oldValuePtr, -1); - } - TRACE(("%u => loop iter count temp %d\n", opnd, iterTmpIndex)); + { + /* + * 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->loopCtTemp; + Var *compiledLocals = iPtr->varFramePtr->compiledLocals; + Var *iterVarPtr = &(compiledLocals[iterTmpIndex]); + Tcl_Obj *oldValuePtr = iterVarPtr->value.objPtr; + if (oldValuePtr == NULL) { + iterVarPtr->value.objPtr = Tcl_NewLongObj(-1); + Tcl_IncrRefCount(iterVarPtr->value.objPtr); + } else { + Tcl_SetLongObj(oldValuePtr, -1); + } + TclSetVarScalar(iterVarPtr); + TclClearVarUndefined(iterVarPtr); + TRACE(("%u => loop iter count temp %d\n", + opnd, iterTmpIndex)); + } + #ifndef TCL_COMPILE_DEBUG - /* - * Remark that the compiler ALWAYS sets INST_FOREACH_STEP4 immediately - * after INST_FOREACH_START4 - let us just fall through instead of - * jumping back to the top. + /* + * Remark that the compiler ALWAYS sets INST_FOREACH_STEP4 + * immediately after INST_FOREACH_START4 - let us just fall + * through instead of jumping back to the top. */ pc += 5; TCL_DTRACE_INST_NEXT(); #else NEXT_INST_F(5, 0, 0); -#endif - +#endif case INST_FOREACH_STEP4: - /* - * "Step" a foreach loop (i.e., begin its next iteration) by assigning - * the next value list element to each loop var. - */ - opnd = TclGetUInt4AtPtr(pc+1); - infoPtr = codePtr->auxDataArrayPtr[opnd].clientData; - numLists = infoPtr->numLists; - - /* - * Increment the temp holding the loop iteration number. - */ - - iterVarPtr = LOCAL(infoPtr->loopCtTemp); - valuePtr = iterVarPtr->value.objPtr; - iterNum = valuePtr->internalRep.longValue + 1; - TclSetLongObj(valuePtr, iterNum); + { + /* + * "Step" a foreach loop (i.e., begin its next iteration) by + * assigning the next value list element to each loop var. + */ - /* - * Check whether all value lists are exhausted and we should stop the - * loop. - */ + ForeachInfo *infoPtr = (ForeachInfo *) + codePtr->auxDataArrayPtr[opnd].clientData; + ForeachVarList *varListPtr; + int numLists = infoPtr->numLists; + Var *compiledLocals = iPtr->varFramePtr->compiledLocals; + Tcl_Obj *listPtr; + Var *iterVarPtr, *listVarPtr; + int iterNum, listTmpIndex, listLen, numVars; + int varIndex, valIndex, continueLoop, j; - continueLoop = 0; - listTmpIndex = infoPtr->firstValueTemp; - for (i = 0; i < numLists; i++) { - varListPtr = infoPtr->varLists[i]; - numVars = varListPtr->numVars; - - listVarPtr = LOCAL(listTmpIndex); - listPtr = listVarPtr->value.objPtr; - if (TclListObjLength(interp, listPtr, &listLen) != TCL_OK) { - TRACE_WITH_OBJ(("%u => ERROR converting list %ld, \"%s\": ", - opnd, i, O2S(listPtr)), Tcl_GetObjResult(interp)); - goto gotError; - } - if (listLen > iterNum * numVars) { - continueLoop = 1; - } - listTmpIndex++; - } + /* + * Increment the temp holding the loop iteration number. + */ - /* - * 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 (by calling Tcl_ListObjLength), but cannot rely - * on that check remaining valid: one list could have been shimmered - * as a side effect of setting a traced variable. - */ + iterVarPtr = &(compiledLocals[infoPtr->loopCtTemp]); + valuePtr = iterVarPtr->value.objPtr; + iterNum = (valuePtr->internalRep.longValue + 1); + Tcl_SetLongObj(valuePtr, iterNum); + + /* + * Check whether all value lists are exhausted and we should + * stop the loop. + */ - if (continueLoop) { + continueLoop = 0; listTmpIndex = infoPtr->firstValueTemp; 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(("%u => ERROR converting list %ld, \"%s\": ", + opnd, i, O2S(listPtr)), Tcl_GetObjResult(interp)); + goto checkForCatch; + } + if (listLen > (iterNum * numVars)) { + continueLoop = 1; + } + listTmpIndex++; + } - listVarPtr = LOCAL(listTmpIndex); - listPtr = TclListObjCopy(NULL, listVarPtr->value.objPtr); - TclListObjGetElements(interp, listPtr, &listLen, &elements); + /* + * 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->firstValueTemp; + for (i = 0; i < numLists; i++) { + varListPtr = infoPtr->varLists[i]; + numVars = varListPtr->numVars; - valIndex = (iterNum * numVars); - for (j = 0; j < numVars; j++) { - if (valIndex >= listLen) { - TclNewObj(valuePtr); - } else { - valuePtr = elements[valIndex]; - } + listVarPtr = &(compiledLocals[listTmpIndex]); + listPtr = listVarPtr->value.objPtr; - varIndex = varListPtr->varIndexes[j]; - varPtr = LOCAL(varIndex); - while (TclIsVarLink(varPtr)) { - varPtr = varPtr->value.linkPtr; - } - if (TclIsVarDirectWritable(varPtr)) { - value2Ptr = varPtr->value.objPtr; - if (valuePtr != value2Ptr) { - if (value2Ptr != NULL) { - TclDecrRefCount(value2Ptr); + valIndex = (iterNum * numVars); + for (j = 0; j < numVars; j++) { + Tcl_Obj **elements; + + /* + * The call to TclPtrSetVar might shimmer listPtr, + * so re-fetch pointers every iteration for safety. + * See test foreach-10.1. + */ + + Tcl_ListObjGetElements(NULL, listPtr, + &listLen, &elements); + if (valIndex >= listLen) { + TclNewObj(valuePtr); + } else { + valuePtr = elements[valIndex]; + } + + varIndex = varListPtr->varIndexes[j]; + varPtr = &(varFramePtr->compiledLocals[varIndex]); + part1 = varPtr->name; + while (TclIsVarLink(varPtr)) { + varPtr = varPtr->value.linkPtr; + } + if (!((varPtr->flags & VAR_IN_HASHTABLE) && (varPtr->hPtr == NULL)) + && (varPtr->tracePtr == NULL) + && (TclIsVarScalar(varPtr) || TclIsVarUndefined(varPtr))) { + value2Ptr = varPtr->value.objPtr; + if (valuePtr != value2Ptr) { + if (value2Ptr != NULL) { + TclDecrRefCount(value2Ptr); + } else { + TclSetVarScalar(varPtr); + TclClearVarUndefined(varPtr); + } + varPtr->value.objPtr = valuePtr; + Tcl_IncrRefCount(valuePtr); } - varPtr->value.objPtr = valuePtr; + } else { + DECACHE_STACK_INFO(); Tcl_IncrRefCount(valuePtr); - } - } else { - DECACHE_STACK_INFO(); - if (TclPtrSetVar(interp, varPtr, NULL, NULL, NULL, - valuePtr, TCL_LEAVE_ERR_MSG, varIndex)==NULL){ + value2Ptr = TclPtrSetVar(interp, varPtr, NULL, part1, + NULL, valuePtr, TCL_LEAVE_ERR_MSG); + TclDecrRefCount(valuePtr); CACHE_STACK_INFO(); - TRACE_WITH_OBJ(( - "%u => ERROR init. index temp %d: ", - opnd,varIndex), Tcl_GetObjResult(interp)); - TclDecrRefCount(listPtr); - goto gotError; + if (value2Ptr == NULL) { + TRACE_WITH_OBJ(("%u => ERROR init. index temp %d: ", + opnd, varIndex), + Tcl_GetObjResult(interp)); + result = TCL_ERROR; + goto checkForCatch; + } } - CACHE_STACK_INFO(); + valIndex++; } - valIndex++; + listTmpIndex++; } - TclDecrRefCount(listPtr); - listTmpIndex++; } - } - TRACE(("%u => %d lists, iter %d, %s loop\n", opnd, numLists, - iterNum, (continueLoop? "continue" : "exit"))); + TRACE(("%u => %d lists, iter %d, %s loop\n", opnd, numLists, + iterNum, (continueLoop? "continue" : "exit"))); - /* - * Run-time peep-hole optimisation: the compiler ALWAYS follows - * INST_FOREACH_STEP4 with an INST_JUMP_FALSE. We just skip that - * instruction and jump direct from here. - */ + /* + * Run-time peep-hole optimisation: the compiler ALWAYS follows + * INST_FOREACH_STEP4 with an INST_JUMP_FALSE. We just skip that + * instruction and jump direct from here. + */ - pc += 5; - if (*pc == INST_JUMP_FALSE1) { - NEXT_INST_F((continueLoop? 2 : TclGetInt1AtPtr(pc+1)), 0, 0); - } else { - NEXT_INST_F((continueLoop? 5 : TclGetInt4AtPtr(pc+1)), 0, 0); + pc += 5; + if (*pc == INST_JUMP_FALSE1) { + NEXT_INST_F((continueLoop? 2 : TclGetInt1AtPtr(pc+1)), 0, 0); + } else { + NEXT_INST_F((continueLoop? 5 : TclGetInt4AtPtr(pc+1)), 0, 0); + } } - } 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. + * Record start of the catch command with exception range index + * equal to the operand. Push the current stack depth onto the + * special catch stack. */ - - *(++catchTop) = CURR_DEPTH; + catchStackPtr[++catchTop] = stackTop; TRACE(("%u => catchTop=%d, stackTop=%d\n", - TclGetUInt4AtPtr(pc+1), (int) (catchTop - initCatchTop - 1), - (int) CURR_DEPTH)); + TclGetUInt4AtPtr(pc+1), catchTop, stackTop)); NEXT_INST_F(5, 0, 0); case INST_END_CATCH: catchTop--; - DECACHE_STACK_INFO(); - Tcl_ResetResult(interp); - CACHE_STACK_INFO(); result = TCL_OK; - TRACE(("=> catchTop=%d\n", (int) (catchTop - initCatchTop - 1))); + TRACE(("=> catchTop=%d\n", catchTop)); NEXT_INST_F(1, 0, 0); - + case INST_PUSH_RESULT: objResultPtr = Tcl_GetObjResult(interp); - TRACE_WITH_OBJ(("=> "), objResultPtr); + TRACE_WITH_OBJ(("=> "), Tcl_GetObjResult(interp)); /* * See the comments at INST_INVOKE_STK */ + { + Tcl_Obj *newObjResultPtr; + TclNewObj(newObjResultPtr); + Tcl_IncrRefCount(newObjResultPtr); + iPtr->objResultPtr = newObjResultPtr; + } - TclNewObj(objPtr); - Tcl_IncrRefCount(objPtr); - iPtr->objResultPtr = objPtr; NEXT_INST_F(1, 0, -1); case INST_PUSH_RETURN_CODE: - TclNewIntObj(objResultPtr, result); + objResultPtr = Tcl_NewLongObj(result); TRACE(("=> %u\n", result)); NEXT_INST_F(1, 0, 1); - case INST_PUSH_RETURN_OPTIONS: - DECACHE_STACK_INFO(); - objResultPtr = Tcl_GetReturnOptions(interp, result); - CACHE_STACK_INFO(); - TRACE_WITH_OBJ(("=> "), objResultPtr); - NEXT_INST_F(1, 0, 1); - - case INST_RETURN_CODE_BRANCH: { - int code; - - if (TclGetIntFromObj(NULL, OBJ_AT_TOS, &code) != TCL_OK) { - Tcl_Panic("INST_RETURN_CODE_BRANCH: TOS not a return code!"); - } - if (code == TCL_OK) { - Tcl_Panic("INST_RETURN_CODE_BRANCH: TOS is TCL_OK!"); - } - if (code < TCL_ERROR || code > TCL_CONTINUE) { - code = TCL_CONTINUE + 1; - } - NEXT_INST_F(2*code -1, 1, 0); - } - - /* - * ----------------------------------------------------------------- - * Start of dictionary-related instructions. - */ - - { - int opnd2, allocateDict, done, i, allocdict; - Tcl_Obj *dictPtr, *statePtr, *keyPtr, *listPtr, *varNamePtr, *keysPtr; - Tcl_Obj *emptyPtr, **keyPtrPtr; - Tcl_DictSearch *searchPtr; - DictUpdateInfo *duiPtr; - - case INST_DICT_GET: - opnd = TclGetUInt4AtPtr(pc+1); - TRACE(("%u => ", opnd)); - dictPtr = OBJ_AT_DEPTH(opnd); - if (opnd > 1) { - dictPtr = TclTraceDictPath(interp, dictPtr, opnd-1, - &OBJ_AT_DEPTH(opnd-1), DICT_PATH_READ); - if (dictPtr == NULL) { - TRACE_WITH_OBJ(( - "%u => ERROR tracing dictionary path into \"%s\": ", - opnd, O2S(OBJ_AT_DEPTH(opnd))), - Tcl_GetObjResult(interp)); - goto gotError; - } - } - if (Tcl_DictObjGet(interp, dictPtr, OBJ_AT_TOS, - &objResultPtr) == TCL_OK) { - if (objResultPtr) { - TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); - NEXT_INST_V(5, opnd+1, 1); - } - DECACHE_STACK_INFO(); - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "key \"", TclGetString(OBJ_AT_TOS), - "\" not known in dictionary", NULL); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "DICT", - TclGetString(OBJ_AT_TOS), NULL); - CACHE_STACK_INFO(); - TRACE_WITH_OBJ(("%u => ERROR ", opnd), Tcl_GetObjResult(interp)); - } else { - TRACE_WITH_OBJ(( - "%u => ERROR reading leaf dictionary key \"%s\": ", - opnd, O2S(dictPtr)), Tcl_GetObjResult(interp)); - } - goto gotError; - - case INST_DICT_SET: - case INST_DICT_UNSET: - case INST_DICT_INCR_IMM: - opnd = TclGetUInt4AtPtr(pc+1); - opnd2 = TclGetUInt4AtPtr(pc+5); - - varPtr = LOCAL(opnd2); - while (TclIsVarLink(varPtr)) { - varPtr = varPtr->value.linkPtr; - } - TRACE(("%u %u => ", opnd, opnd2)); - if (TclIsVarDirectReadable(varPtr)) { - dictPtr = varPtr->value.objPtr; - } else { - DECACHE_STACK_INFO(); - dictPtr = TclPtrGetVar(interp, varPtr, NULL,NULL,NULL, 0, opnd2); - CACHE_STACK_INFO(); - } - if (dictPtr == NULL) { - TclNewObj(dictPtr); - allocateDict = 1; - } else { - allocateDict = Tcl_IsShared(dictPtr); - if (allocateDict) { - dictPtr = Tcl_DuplicateObj(dictPtr); - } - } - - switch (*pc) { - case INST_DICT_SET: - cleanup = opnd + 1; - result = Tcl_DictObjPutKeyList(interp, dictPtr, opnd, - &OBJ_AT_DEPTH(opnd), OBJ_AT_TOS); - break; - case INST_DICT_INCR_IMM: - cleanup = 1; - opnd = TclGetInt4AtPtr(pc+1); - result = Tcl_DictObjGet(interp, dictPtr, OBJ_AT_TOS, &valuePtr); - if (result != TCL_OK) { - break; - } - if (valuePtr == NULL) { - Tcl_DictObjPut(NULL, dictPtr, OBJ_AT_TOS,Tcl_NewIntObj(opnd)); - } else { - value2Ptr = Tcl_NewIntObj(opnd); - Tcl_IncrRefCount(value2Ptr); - if (Tcl_IsShared(valuePtr)) { - valuePtr = Tcl_DuplicateObj(valuePtr); - Tcl_DictObjPut(NULL, dictPtr, OBJ_AT_TOS, valuePtr); - } - result = TclIncrObj(interp, valuePtr, value2Ptr); - if (result == TCL_OK) { - TclInvalidateStringRep(dictPtr); - } - TclDecrRefCount(value2Ptr); - } - break; - case INST_DICT_UNSET: - cleanup = opnd; - result = Tcl_DictObjRemoveKeyList(interp, dictPtr, opnd, - &OBJ_AT_DEPTH(opnd-1)); - break; - default: - cleanup = 0; /* stop compiler warning */ - Tcl_Panic("Should not happen!"); - } - - if (result != TCL_OK) { - if (allocateDict) { - TclDecrRefCount(dictPtr); - } - TRACE_WITH_OBJ(("%u %u => ERROR updating dictionary: ", - opnd, opnd2), Tcl_GetObjResult(interp)); - goto checkForCatch; - } - - if (TclIsVarDirectWritable(varPtr)) { - if (allocateDict) { - value2Ptr = varPtr->value.objPtr; - Tcl_IncrRefCount(dictPtr); - if (value2Ptr != NULL) { - TclDecrRefCount(value2Ptr); - } - varPtr->value.objPtr = dictPtr; - } - objResultPtr = dictPtr; - } else { - Tcl_IncrRefCount(dictPtr); - DECACHE_STACK_INFO(); - objResultPtr = TclPtrSetVar(interp, varPtr, NULL, NULL, NULL, - dictPtr, TCL_LEAVE_ERR_MSG, opnd2); - CACHE_STACK_INFO(); - TclDecrRefCount(dictPtr); - if (objResultPtr == NULL) { - TRACE_APPEND(("ERROR: %.30s\n", - O2S(Tcl_GetObjResult(interp)))); - goto gotError; - } - } -#ifndef TCL_COMPILE_DEBUG - if (*(pc+9) == INST_POP) { - NEXT_INST_V(10, cleanup, 0); - } -#endif - TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); - NEXT_INST_V(9, cleanup, 1); - - case INST_DICT_APPEND: - case INST_DICT_LAPPEND: - opnd = TclGetUInt4AtPtr(pc+1); - varPtr = LOCAL(opnd); - while (TclIsVarLink(varPtr)) { - varPtr = varPtr->value.linkPtr; - } - TRACE(("%u => ", opnd)); - if (TclIsVarDirectReadable(varPtr)) { - dictPtr = varPtr->value.objPtr; - } else { - DECACHE_STACK_INFO(); - dictPtr = TclPtrGetVar(interp, varPtr, NULL, NULL, NULL, 0, opnd); - CACHE_STACK_INFO(); - } - if (dictPtr == NULL) { - TclNewObj(dictPtr); - allocateDict = 1; - } else { - allocateDict = Tcl_IsShared(dictPtr); - if (allocateDict) { - dictPtr = Tcl_DuplicateObj(dictPtr); - } - } - - if (Tcl_DictObjGet(interp, dictPtr, OBJ_UNDER_TOS, - &valuePtr) != TCL_OK) { - if (allocateDict) { - TclDecrRefCount(dictPtr); - } - goto gotError; - } - - /* - * Note that a non-existent key results in a NULL valuePtr, which is a - * case handled separately below. What we *can* say at this point is - * that the write-back will always succeed. - */ - - switch (*pc) { - case INST_DICT_APPEND: - if (valuePtr == NULL) { - Tcl_DictObjPut(NULL, dictPtr, OBJ_UNDER_TOS, OBJ_AT_TOS); - } else if (Tcl_IsShared(valuePtr)) { - valuePtr = Tcl_DuplicateObj(valuePtr); - Tcl_AppendObjToObj(valuePtr, OBJ_AT_TOS); - Tcl_DictObjPut(NULL, dictPtr, OBJ_UNDER_TOS, valuePtr); - } else { - Tcl_AppendObjToObj(valuePtr, OBJ_AT_TOS); - - /* - * Must invalidate the string representation of dictionary - * here because we have directly updated the internal - * representation; if we don't, callers could see the wrong - * string rep despite the internal version of the dictionary - * having the correct value. [Bug 3079830] - */ - - TclInvalidateStringRep(dictPtr); - } - break; - case INST_DICT_LAPPEND: - /* - * More complex because list-append can fail. - */ - - if (valuePtr == NULL) { - Tcl_DictObjPut(NULL, dictPtr, OBJ_UNDER_TOS, - Tcl_NewListObj(1, &OBJ_AT_TOS)); - break; - } else if (Tcl_IsShared(valuePtr)) { - valuePtr = Tcl_DuplicateObj(valuePtr); - if (Tcl_ListObjAppendElement(interp, valuePtr, - OBJ_AT_TOS) != TCL_OK) { - TclDecrRefCount(valuePtr); - if (allocateDict) { - TclDecrRefCount(dictPtr); - } - goto gotError; - } - Tcl_DictObjPut(NULL, dictPtr, OBJ_UNDER_TOS, valuePtr); - } else { - if (Tcl_ListObjAppendElement(interp, valuePtr, - OBJ_AT_TOS) != TCL_OK) { - if (allocateDict) { - TclDecrRefCount(dictPtr); - } - goto gotError; - } - - /* - * Must invalidate the string representation of dictionary - * here because we have directly updated the internal - * representation; if we don't, callers could see the wrong - * string rep despite the internal version of the dictionary - * having the correct value. [Bug 3079830] - */ - - TclInvalidateStringRep(dictPtr); - } - break; - default: - Tcl_Panic("Should not happen!"); - } - - if (TclIsVarDirectWritable(varPtr)) { - if (allocateDict) { - value2Ptr = varPtr->value.objPtr; - Tcl_IncrRefCount(dictPtr); - if (value2Ptr != NULL) { - TclDecrRefCount(value2Ptr); - } - varPtr->value.objPtr = dictPtr; - } - objResultPtr = dictPtr; - } else { - Tcl_IncrRefCount(dictPtr); - DECACHE_STACK_INFO(); - objResultPtr = TclPtrSetVar(interp, varPtr, NULL, NULL, NULL, - dictPtr, TCL_LEAVE_ERR_MSG, opnd); - CACHE_STACK_INFO(); - TclDecrRefCount(dictPtr); - if (objResultPtr == NULL) { - TRACE_APPEND(("ERROR: %.30s\n", - O2S(Tcl_GetObjResult(interp)))); - goto gotError; - } - } -#ifndef TCL_COMPILE_DEBUG - if (*(pc+5) == INST_POP) { - NEXT_INST_F(6, 2, 0); - } -#endif - TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); - NEXT_INST_F(5, 2, 1); - - case INST_DICT_FIRST: - opnd = TclGetUInt4AtPtr(pc+1); - TRACE(("%u => ", opnd)); - dictPtr = POP_OBJECT(); - searchPtr = ckalloc(sizeof(Tcl_DictSearch)); - if (Tcl_DictObjFirst(interp, dictPtr, searchPtr, &keyPtr, - &valuePtr, &done) != TCL_OK) { - ckfree(searchPtr); - goto gotError; - } - TclNewObj(statePtr); - statePtr->typePtr = &dictIteratorType; - statePtr->internalRep.twoPtrValue.ptr1 = searchPtr; - statePtr->internalRep.twoPtrValue.ptr2 = dictPtr; - varPtr = LOCAL(opnd); - if (varPtr->value.objPtr) { - if (varPtr->value.objPtr->typePtr == &dictIteratorType) { - Tcl_Panic("mis-issued dictFirst!"); - } - TclDecrRefCount(varPtr->value.objPtr); - } - varPtr->value.objPtr = statePtr; - Tcl_IncrRefCount(statePtr); - goto pushDictIteratorResult; - - case INST_DICT_NEXT: - opnd = TclGetUInt4AtPtr(pc+1); - TRACE(("%u => ", opnd)); - statePtr = (*LOCAL(opnd)).value.objPtr; - if (statePtr == NULL || statePtr->typePtr != &dictIteratorType) { - Tcl_Panic("mis-issued dictNext!"); - } - searchPtr = statePtr->internalRep.twoPtrValue.ptr1; - Tcl_DictObjNext(searchPtr, &keyPtr, &valuePtr, &done); - pushDictIteratorResult: - if (done) { - TclNewObj(emptyPtr); - PUSH_OBJECT(emptyPtr); - PUSH_OBJECT(emptyPtr); - } else { - PUSH_OBJECT(valuePtr); - PUSH_OBJECT(keyPtr); - } - -#ifndef TCL_COMPILE_DEBUG - /* - * The INST_DICT_FIRST and INST_DICT_NEXT instructsions are always - * followed by a conditional jump, so we can take advantage of this to - * do some peephole optimization (note that we're careful to not close - * out someone doing something else). - */ - - pc += 5; - switch (*pc) { - case INST_JUMP_FALSE1: - NEXT_INST_F((done ? 2 : TclGetInt1AtPtr(pc+1)), 0, 0); - case INST_JUMP_FALSE4: - NEXT_INST_F((done ? 5 : TclGetInt4AtPtr(pc+1)), 0, 0); - case INST_JUMP_TRUE1: - NEXT_INST_F((done ? TclGetInt1AtPtr(pc+1) : 2), 0, 0); - case INST_JUMP_TRUE4: - NEXT_INST_F((done ? TclGetInt4AtPtr(pc+1) : 5), 0, 0); - default: - pc -= 5; - /* fall through to non-debug handling */ - } -#endif - - TRACE_APPEND(("\"%.30s\" \"%.30s\" %d", - O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS), done)); - objResultPtr = TCONST(done); - /* TODO: consider opt like INST_FOREACH_STEP4 */ - NEXT_INST_F(5, 0, 1); - - case INST_DICT_UPDATE_START: - opnd = TclGetUInt4AtPtr(pc+1); - opnd2 = TclGetUInt4AtPtr(pc+5); - varPtr = LOCAL(opnd); - duiPtr = codePtr->auxDataArrayPtr[opnd2].clientData; - while (TclIsVarLink(varPtr)) { - varPtr = varPtr->value.linkPtr; - } - TRACE(("%u => ", opnd)); - if (TclIsVarDirectReadable(varPtr)) { - dictPtr = varPtr->value.objPtr; - } else { - DECACHE_STACK_INFO(); - dictPtr = TclPtrGetVar(interp, varPtr, NULL, NULL, NULL, - TCL_LEAVE_ERR_MSG, opnd); - CACHE_STACK_INFO(); - if (dictPtr == NULL) { - goto gotError; - } - } - if (TclListObjGetElements(interp, OBJ_AT_TOS, &length, - &keyPtrPtr) != TCL_OK) { - goto gotError; - } - if (length != duiPtr->length) { - Tcl_Panic("dictUpdateStart argument length mismatch"); - } - for (i=0 ; i<length ; i++) { - if (Tcl_DictObjGet(interp, dictPtr, keyPtrPtr[i], - &valuePtr) != TCL_OK) { - goto gotError; - } - varPtr = LOCAL(duiPtr->varIndices[i]); - while (TclIsVarLink(varPtr)) { - varPtr = varPtr->value.linkPtr; - } - DECACHE_STACK_INFO(); - if (valuePtr == NULL) { - TclObjUnsetVar2(interp, - localName(iPtr->varFramePtr, duiPtr->varIndices[i]), - NULL, 0); - } else if (TclPtrSetVar(interp, varPtr, NULL, NULL, NULL, - valuePtr, TCL_LEAVE_ERR_MSG, - duiPtr->varIndices[i]) == NULL) { - CACHE_STACK_INFO(); - goto gotError; - } - CACHE_STACK_INFO(); - } - NEXT_INST_F(9, 0, 0); - - case INST_DICT_UPDATE_END: - opnd = TclGetUInt4AtPtr(pc+1); - opnd2 = TclGetUInt4AtPtr(pc+5); - varPtr = LOCAL(opnd); - duiPtr = codePtr->auxDataArrayPtr[opnd2].clientData; - while (TclIsVarLink(varPtr)) { - varPtr = varPtr->value.linkPtr; - } - TRACE(("%u => ", opnd)); - if (TclIsVarDirectReadable(varPtr)) { - dictPtr = varPtr->value.objPtr; - } else { - DECACHE_STACK_INFO(); - dictPtr = TclPtrGetVar(interp, varPtr, NULL, NULL, NULL, 0, opnd); - CACHE_STACK_INFO(); - } - if (dictPtr == NULL) { - NEXT_INST_F(9, 1, 0); - } - if (Tcl_DictObjSize(interp, dictPtr, &length) != TCL_OK - || TclListObjGetElements(interp, OBJ_AT_TOS, &length, - &keyPtrPtr) != TCL_OK) { - goto gotError; - } - allocdict = Tcl_IsShared(dictPtr); - if (allocdict) { - dictPtr = Tcl_DuplicateObj(dictPtr); - } - if (length > 0) { - TclInvalidateStringRep(dictPtr); - } - for (i=0 ; i<length ; i++) { - Var *var2Ptr = LOCAL(duiPtr->varIndices[i]); - - while (TclIsVarLink(var2Ptr)) { - var2Ptr = var2Ptr->value.linkPtr; - } - if (TclIsVarDirectReadable(var2Ptr)) { - valuePtr = var2Ptr->value.objPtr; - } else { - DECACHE_STACK_INFO(); - valuePtr = TclPtrGetVar(interp, var2Ptr, NULL, NULL, NULL, 0, - duiPtr->varIndices[i]); - CACHE_STACK_INFO(); - } - if (valuePtr == NULL) { - Tcl_DictObjRemove(interp, dictPtr, keyPtrPtr[i]); - } else if (dictPtr == valuePtr) { - Tcl_DictObjPut(interp, dictPtr, keyPtrPtr[i], - Tcl_DuplicateObj(valuePtr)); - } else { - Tcl_DictObjPut(interp, dictPtr, keyPtrPtr[i], valuePtr); - } - } - if (TclIsVarDirectWritable(varPtr)) { - Tcl_IncrRefCount(dictPtr); - TclDecrRefCount(varPtr->value.objPtr); - varPtr->value.objPtr = dictPtr; - } else { - DECACHE_STACK_INFO(); - objResultPtr = TclPtrSetVar(interp, varPtr, NULL, NULL, NULL, - dictPtr, TCL_LEAVE_ERR_MSG, opnd); - CACHE_STACK_INFO(); - if (objResultPtr == NULL) { - if (allocdict) { - TclDecrRefCount(dictPtr); - } - goto gotError; - } - } - NEXT_INST_F(9, 1, 0); - - case INST_DICT_EXPAND: - dictPtr = OBJ_UNDER_TOS; - listPtr = OBJ_AT_TOS; - if (TclListObjGetElements(interp, listPtr, &objc, &objv) != TCL_OK) { - TRACE_WITH_OBJ(("%.30s %.30s => ERROR: ", - O2S(dictPtr), O2S(listPtr)), Tcl_GetObjResult(interp)); - goto gotError; - } - objResultPtr = TclDictWithInit(interp, dictPtr, objc, objv); - if (objResultPtr == NULL) { - TRACE_WITH_OBJ(("%.30s %.30s => ERROR: ", - O2S(dictPtr), O2S(listPtr)), Tcl_GetObjResult(interp)); - goto gotError; - } - TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); - NEXT_INST_F(1, 2, 1); - - case INST_DICT_RECOMBINE_STK: - keysPtr = POP_OBJECT(); - varNamePtr = OBJ_UNDER_TOS; - listPtr = OBJ_AT_TOS; - TRACE(("\"%.30s\" \"%.30s\" \"%.30s\" => ", - O2S(varNamePtr), O2S(valuePtr), O2S(keysPtr))); - if (TclListObjGetElements(interp, listPtr, &objc, &objv) != TCL_OK) { - TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); - TclDecrRefCount(keysPtr); - goto gotError; - } - varPtr = TclObjLookupVarEx(interp, varNamePtr, NULL, - TCL_LEAVE_ERR_MSG, "set", 1, 1, &arrayPtr); - if (varPtr == NULL) { - TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); - TclDecrRefCount(keysPtr); - goto gotError; - } - DECACHE_STACK_INFO(); - result = TclDictWithFinish(interp, varPtr,arrayPtr,varNamePtr,NULL,-1, - objc, objv, keysPtr); - CACHE_STACK_INFO(); - TclDecrRefCount(keysPtr); - if (result != TCL_OK) { - TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); - goto gotError; - } - TRACE_APPEND(("OK\n")); - NEXT_INST_F(1, 2, 0); - - case INST_DICT_RECOMBINE_IMM: - opnd = TclGetUInt4AtPtr(pc+1); - listPtr = OBJ_UNDER_TOS; - keysPtr = OBJ_AT_TOS; - varPtr = LOCAL(opnd); - TRACE(("%u <- \"%.30s\" \"%.30s\" => ", opnd, O2S(valuePtr), - O2S(keysPtr))); - if (TclListObjGetElements(interp, listPtr, &objc, &objv) != TCL_OK) { - TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); - goto gotError; - } - while (TclIsVarLink(varPtr)) { - varPtr = varPtr->value.linkPtr; - } - DECACHE_STACK_INFO(); - result = TclDictWithFinish(interp, varPtr, NULL, NULL, NULL, opnd, - objc, objv, keysPtr); - CACHE_STACK_INFO(); - if (result != TCL_OK) { - TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); - goto gotError; - } - TRACE_APPEND(("OK\n")); - NEXT_INST_F(5, 2, 0); - } - - /* - * End of dictionary-related instructions. - * ----------------------------------------------------------------- - */ - default: - Tcl_Panic("TclNRExecuteByteCode: unrecognized opCode %u", *pc); + panic("TclExecuteByteCode: unrecognized opCode %u", *pc); } /* end of switch on opCode */ /* - * Block for variables needed to process exception returns. + * Division by zero in an expression. Control only reaches this + * point by "goto divideByZero". + */ + + divideByZero: + DECACHE_STACK_INFO(); + Tcl_ResetResult(interp); + Tcl_AppendToObj(Tcl_GetObjResult(interp), "divide by zero", -1); + Tcl_SetErrorCode(interp, "ARITH", "DIVZERO", "divide by zero", + (char *) NULL); + CACHE_STACK_INFO(); + + result = TCL_ERROR; + goto checkForCatch; + + /* + * An external evaluation (INST_INVOKE or INST_EVAL) returned + * something different from TCL_OK, or else INST_BREAK or + * INST_CONTINUE were called. */ - { - 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. */ - const char *bytes; - - /* - * An external evaluation (INST_INVOKE or INST_EVAL) returned - * something different from TCL_OK, or else INST_BREAK or - * INST_CONTINUE were called. - */ - - processExceptionReturn: -#if TCL_COMPILE_DEBUG - switch (*pc) { - case INST_INVOKE_STK1: - opnd = TclGetUInt1AtPtr(pc+1); - TRACE(("%u => ... after \"%.20s\": ", opnd, cmdNameBuf)); - break; - case INST_INVOKE_STK4: - opnd = TclGetUInt4AtPtr(pc+1); + processExceptionReturn: +#if TCL_COMPILE_DEBUG + switch (*pc) { + case INST_INVOKE_STK1: + case INST_INVOKE_STK4: TRACE(("%u => ... after \"%.20s\": ", opnd, cmdNameBuf)); break; - case INST_EVAL_STK: + case INST_EVAL_STK: /* - * Note that the object at stacktop has to be used before doing - * the cleanup. + * Note that the object at stacktop has to be used + * before doing the cleanup. */ - TRACE(("\"%.30s\" => ", O2S(OBJ_AT_TOS))); + TRACE(("\"%.30s\" => ", O2S(stackPtr[stackTop]))); break; - default: + default: TRACE(("=> ")); + } +#endif + if ((result == TCL_CONTINUE) || (result == TCL_BREAK)) { + rangePtr = GetExceptRangeForPc(pc, /*catchOnly*/ 0, codePtr); + if (rangePtr == NULL) { + TRACE_APPEND(("no encl. loop or catch, returning %s\n", + StringForResultCode(result))); + goto abnormalReturn; + } + if (rangePtr->type == CATCH_EXCEPTION_RANGE) { + TRACE_APPEND(("%s ...\n", StringForResultCode(result))); + goto processCatch; } -#endif - if ((result == TCL_CONTINUE) || (result == TCL_BREAK)) { - rangePtr = GetExceptRangeForPc(pc, /*catchOnly*/ 0, codePtr); - if (rangePtr == NULL) { - TRACE_APPEND(("no encl. loop or catch, returning %s\n", - StringForResultCode(result))); - goto abnormalReturn; - } - if (rangePtr->type == CATCH_EXCEPTION_RANGE) { - TRACE_APPEND(("%s ...\n", StringForResultCode(result))); - goto processCatch; - } - while (cleanup--) { - valuePtr = POP_OBJECT(); - TclDecrRefCount(valuePtr); - } - if (result == TCL_BREAK) { - result = TCL_OK; - pc = (codePtr->codeStart + rangePtr->breakOffset); - TRACE_APPEND(("%s, range at %d, new pc %d\n", - StringForResultCode(result), - rangePtr->codeOffset, rangePtr->breakOffset)); - NEXT_INST_F(0, 0, 0); - } + while (cleanup--) { + valuePtr = POP_OBJECT(); + TclDecrRefCount(valuePtr); + } + if (result == TCL_BREAK) { + result = TCL_OK; + pc = (codePtr->codeStart + rangePtr->breakOffset); + TRACE_APPEND(("%s, range at %d, new pc %d\n", + StringForResultCode(result), + rangePtr->codeOffset, rangePtr->breakOffset)); + NEXT_INST_F(0, 0, 0); + } else { if (rangePtr->continueOffset == -1) { TRACE_APPEND(("%s, loop w/o continue, checking for catch\n", - StringForResultCode(result))); + StringForResultCode(result))); goto checkForCatch; - } + } result = TCL_OK; pc = (codePtr->codeStart + rangePtr->continueOffset); TRACE_APPEND(("%s, range at %d, new pc %d\n", - StringForResultCode(result), - rangePtr->codeOffset, rangePtr->continueOffset)); + StringForResultCode(result), + rangePtr->codeOffset, rangePtr->continueOffset)); NEXT_INST_F(0, 0, 0); } -#if TCL_COMPILE_DEBUG - if (traceInstructions) { +#if TCL_COMPILE_DEBUG + } else if (traceInstructions) { + if ((result != TCL_ERROR) && (result != TCL_RETURN)) { objPtr = Tcl_GetObjResult(interp); - if ((result != TCL_ERROR) && (result != TCL_RETURN)) { - TRACE_APPEND(("OTHER RETURN CODE %d, result= \"%s\"\n ", - result, O2S(objPtr))); - } else { - TRACE_APPEND(("%s, result= \"%s\"\n", - StringForResultCode(result), O2S(objPtr))); - } + TRACE_APPEND(("OTHER RETURN CODE %d, result= \"%s\"\n ", + result, O2S(objPtr))); + } else { + objPtr = Tcl_GetObjResult(interp); + TRACE_APPEND(("%s, result= \"%s\"\n", + StringForResultCode(result), O2S(objPtr))); } #endif - goto checkForCatch; - - /* - * Division by zero in an expression. Control only reaches this point - * by "goto divideByZero". - */ - - divideByZero: - DECACHE_STACK_INFO(); - Tcl_SetResult(interp, "divide by zero", TCL_STATIC); - Tcl_SetErrorCode(interp, "ARITH", "DIVZERO", "divide by zero", NULL); - CACHE_STACK_INFO(); - goto gotError; - - /* - * Exponentiation of zero by negative number in an expression. Control - * only reaches this point by "goto exponOfZero". - */ - - exponOfZero: - DECACHE_STACK_INFO(); - Tcl_SetResult(interp, "exponentiation of zero by negative power", - TCL_STATIC); - Tcl_SetErrorCode(interp, "ARITH", "DOMAIN", - "exponentiation of zero by negative power", NULL); - CACHE_STACK_INFO(); - - /* - * Almost all error paths feed through here rather than assigning to - * result themselves (for a small but consistent saving). - */ - - gotError: - 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 (iPtr->execEnvPtr->rewind) { - goto abnormalReturn; - } - if ((result == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) { - const unsigned char *pcBeg; - - bytes = GetSrcInfoForPc(pc, codePtr, &length, &pcBeg); + } + + /* + * 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)) { + bytes = GetSrcInfoForPc(pc, codePtr, &length); + if (bytes != NULL) { DECACHE_STACK_INFO(); - TclLogCommandInfo(interp, codePtr->source, bytes, - bytes ? length : 0, pcBeg, tosPtr); - CACHE_STACK_INFO(); - } - iPtr->flags &= ~ERR_ALREADY_LOGGED; - - /* - * Clear all expansions that may have started after the last - * INST_BEGIN_CATCH. - */ - - while (auxObjList) { - if ((catchTop != initCatchTop) - && (*catchTop > (ptrdiff_t) - auxObjList->internalRep.ptrAndLongRep.value)) { - break; - } - POP_TAUX_OBJ(); - } - - /* - * We must not catch if the script in progress has been canceled with - * the TCL_CANCEL_UNWIND flag. Instead, it blows outwards until we - * either hit another interpreter (presumably where the script in - * progress has not been canceled) or we get to the top-level. We do - * NOT modify the interpreter result here because we know it will - * already be set prior to vectoring down to this point in the code. - */ - - if (TclCanceled(iPtr) && (Tcl_Canceled(interp, 0) == TCL_ERROR)) { -#ifdef TCL_COMPILE_DEBUG - if (traceInstructions) { - fprintf(stdout, " ... cancel with unwind, returning %s\n", - StringForResultCode(result)); - } -#endif - goto abnormalReturn; - } - - /* - * We must not catch an exceeded limit. Instead, it blows outwards - * until we either hit another interpreter (presumably where the limit - * is not exceeded) or we get to the top-level. - */ - - if (TclLimitExceeded(iPtr->limit)) { -#ifdef TCL_COMPILE_DEBUG - if (traceInstructions) { - fprintf(stdout, " ... limit exceeded, returning %s\n", - StringForResultCode(result)); - } -#endif - goto abnormalReturn; + Tcl_LogCommandInfo(interp, codePtr->source, bytes, length); + CACHE_STACK_INFO(); + iPtr->flags |= ERR_ALREADY_LOGGED; } - if (catchTop == initCatchTop) { + } + if (catchTop == -1) { #ifdef TCL_COMPILE_DEBUG - if (traceInstructions) { - fprintf(stdout, " ... no enclosing catch, returning %s\n", - StringForResultCode(result)); - } -#endif - goto abnormalReturn; + if (traceInstructions) { + fprintf(stdout, " ... no enclosing catch, returning %s\n", + StringForResultCode(result)); } - rangePtr = GetExceptRangeForPc(pc, /*catchOnly*/ 1, codePtr); - if (rangePtr == NULL) { - /* - * This is only possible when compiling a [catch] that sends its - * script to INST_EVAL. Cannot correct the compiler without - * breaking compat with previous .tbc compiled scripts. - */ - -#ifdef TCL_COMPILE_DEBUG - if (traceInstructions) { - fprintf(stdout, " ... no enclosing catch, returning %s\n", - StringForResultCode(result)); - } #endif - goto abnormalReturn; - } - + goto abnormalReturn; + } + rangePtr = GetExceptRangeForPc(pc, /*catchOnly*/ 1, codePtr); + if (rangePtr == NULL) { /* - * 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. + * This is only possible when compiling a [catch] that sends its + * script to INST_EVAL. Cannot correct the compiler without + * breakingcompat with previous .tbc compiled scripts. */ - - processCatch: - while (CURR_DEPTH > *catchTop) { - valuePtr = POP_OBJECT(); - TclDecrRefCount(valuePtr); - } #ifdef TCL_COMPILE_DEBUG if (traceInstructions) { - fprintf(stdout, " ... found catch at %d, catchTop=%d, " - "unwound to %ld, new pc %u\n", - rangePtr->codeOffset, (int) (catchTop - initCatchTop - 1), - (long) *catchTop, (unsigned) rangePtr->catchOffset); + fprintf(stdout, " ... no enclosing catch, returning %s\n", + StringForResultCode(result)); } #endif - pc = (codePtr->codeStart + rangePtr->catchOffset); - NEXT_INST_F(0, 0, 0); /* 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. Panic if the stack is below the - * initial level. - */ - - abnormalReturn: - TCL_DTRACE_INST_LAST(); - - /* - * Clear all expansions and same-level NR calls. - * - * Note that expansion markers have a NULL type; avoid removing other - * markers. - */ - - while (auxObjList) { - POP_TAUX_OBJ(); - } - while (tosPtr > initTosPtr) { - objPtr = POP_OBJECT(); - Tcl_DecrRefCount(objPtr); - } - - if (tosPtr < initTosPtr) { - fprintf(stderr, - "\nTclNRExecuteByteCode: abnormal return at pc %u: " - "stack top %d < entry stack top %d\n", - (unsigned)(pc - codePtr->codeStart), - (unsigned) CURR_DEPTH, (unsigned) 0); - Tcl_Panic("TclNRExecuteByteCode execution failure: end stack top < start stack top"); - } - CLANG_ASSERT(bcFramePtr); - } - - iPtr->cmdFramePtr = bcFramePtr->nextPtr; - if (--codePtr->refCount <= 0) { - TclCleanupByteCode(codePtr); + goto abnormalReturn; } - TclStackFree(interp, TD); /* free my stack */ - return result; -} - -#undef codePtr -#undef iPtr -#undef bcFramePtr -#undef initCatchTop -#undef initTosPtr -#undef auxObjList -#undef catchTop -#undef TCONST - -/* - *---------------------------------------------------------------------- - * - * ExecuteExtendedBinaryMathOp, ExecuteExtendedUnaryMathOp -- - * - * These functions do advanced math for binary and unary operators - * respectively, so that the main TEBC code does not bear the cost of - * them. - * - * Results: - * A Tcl_Obj* result, or a NULL (in which case valuePtr is updated to - * hold the result value), or one of the special flag values - * GENERAL_ARITHMETIC_ERROR, EXPONENT_OF_ZERO or DIVIDED_BY_ZERO. The - * latter two signify a zero value raised to a negative power or a value - * divided by zero, respectively. With GENERAL_ARITHMETIC_ERROR, all - * error information will have already been reported in the interpreter - * result. - * - * Side effects: - * May update the Tcl_Obj indicated valuePtr if it is unshared. Will - * return a NULL when that happens. - * - *---------------------------------------------------------------------- - */ + /* + * 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. + */ -static Tcl_Obj * -ExecuteExtendedBinaryMathOp( - Tcl_Interp *interp, /* Where to report errors. */ - int opcode, /* What operation to perform. */ - Tcl_Obj **constants, /* The execution environment's constants. */ - Tcl_Obj *valuePtr, /* The first operand on the stack. */ - Tcl_Obj *value2Ptr) /* The second operand on the stack. */ -{ -#define LONG_RESULT(l) \ - if (Tcl_IsShared(valuePtr)) { \ - TclNewLongObj(objResultPtr, l); \ - return objResultPtr; \ - } else { \ - Tcl_SetLongObj(valuePtr, l); \ - return NULL; \ - } -#define WIDE_RESULT(w) \ - if (Tcl_IsShared(valuePtr)) { \ - return Tcl_NewWideIntObj(w); \ - } else { \ - Tcl_SetWideIntObj(valuePtr, w); \ - return NULL; \ - } -#define BIG_RESULT(b) \ - if (Tcl_IsShared(valuePtr)) { \ - return Tcl_NewBignumObj(b); \ - } else { \ - Tcl_SetBignumObj(valuePtr, b); \ - return NULL; \ - } -#define DOUBLE_RESULT(d) \ - if (Tcl_IsShared(valuePtr)) { \ - TclNewDoubleObj(objResultPtr, (d)); \ - return objResultPtr; \ - } else { \ - Tcl_SetDoubleObj(valuePtr, (d)); \ - return NULL; \ + processCatch: + while (stackTop > catchStackPtr[catchTop]) { + valuePtr = POP_OBJECT(); + TclDecrRefCount(valuePtr); } - - int type1, type2; - ClientData ptr1, ptr2; - double d1, d2, dResult; - long l1, l2, lResult; - Tcl_WideInt w1, w2, wResult; - mp_int big1, big2, bigResult, bigRemainder; - Tcl_Obj *objResultPtr; - int invalid, numPos, zero; - long shift; - - (void) GetNumberFromObj(NULL, valuePtr, &ptr1, &type1); - (void) GetNumberFromObj(NULL, value2Ptr, &ptr2, &type2); - - switch (opcode) { - case INST_MOD: - /* TODO: Attempts to re-use unshared operands on stack */ - - l2 = 0; /* silence gcc warning */ - if (type2 == TCL_NUMBER_LONG) { - l2 = *((const long *)ptr2); - if (l2 == 0) { - return DIVIDED_BY_ZERO; - } - if ((l2 == 1) || (l2 == -1)) { - /* - * Div. by |1| always yields remainder of 0. - */ - - return constants[0]; - } - } -#ifndef NO_WIDE_TYPE - if (type1 == TCL_NUMBER_WIDE) { - w1 = *((const Tcl_WideInt *)ptr1); - if (type2 != TCL_NUMBER_BIG) { - Tcl_WideInt wQuotient, wRemainder; - Tcl_GetWideIntFromObj(NULL, value2Ptr, &w2); - wQuotient = w1 / w2; - - /* - * Force Tcl's integer division rules. - * TODO: examine for logic simplification - */ - - if (((wQuotient < (Tcl_WideInt) 0) - || ((wQuotient == (Tcl_WideInt) 0) - && ((w1 < (Tcl_WideInt)0 && w2 > (Tcl_WideInt)0) - || (w1 > (Tcl_WideInt)0 && w2 < (Tcl_WideInt)0)))) - && (wQuotient * w2 != w1)) { - wQuotient -= (Tcl_WideInt) 1; - } - wRemainder = w1 - w2*wQuotient; - WIDE_RESULT(wRemainder); - } - - Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2); - - /* TODO: internals intrusion */ - if ((w1 > ((Tcl_WideInt) 0)) ^ (big2.sign == MP_ZPOS)) { - /* - * Arguments are opposite sign; remainder is sum. - */ - - TclBNInitBignumFromWideInt(&big1, w1); - mp_add(&big2, &big1, &big2); - mp_clear(&big1); - BIG_RESULT(&big2); - } - - /* - * Arguments are same sign; remainder is first operand. - */ - - mp_clear(&big2); - return NULL; - } -#endif - Tcl_GetBignumFromObj(NULL, valuePtr, &big1); - Tcl_GetBignumFromObj(NULL, value2Ptr, &big2); - mp_init(&bigResult); - mp_init(&bigRemainder); - mp_div(&big1, &big2, &bigResult, &bigRemainder); - if (!mp_iszero(&bigRemainder) && (bigRemainder.sign != big2.sign)) { - /* - * Convert to Tcl's integer division rules. - */ - - mp_sub_d(&bigResult, 1, &bigResult); - mp_add(&bigRemainder, &big2, &bigRemainder); - } - mp_copy(&bigRemainder, &bigResult); - mp_clear(&bigRemainder); - mp_clear(&big1); - mp_clear(&big2); - BIG_RESULT(&bigResult); - - case INST_LSHIFT: - case INST_RSHIFT: { - /* - * Reject negative shift argument. - */ - - switch (type2) { - case TCL_NUMBER_LONG: - invalid = (*((const long *)ptr2) < 0L); - break; -#ifndef NO_WIDE_TYPE - case TCL_NUMBER_WIDE: - invalid = (*((const Tcl_WideInt *)ptr2) < (Tcl_WideInt)0); - break; -#endif - case TCL_NUMBER_BIG: - Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2); - invalid = (mp_cmp_d(&big2, 0) == MP_LT); - mp_clear(&big2); - break; - default: - /* Unused, here to silence compiler warning */ - invalid = 0; - } - if (invalid) { - Tcl_SetResult(interp, "negative shift argument", TCL_STATIC); - return GENERAL_ARITHMETIC_ERROR; - } - - /* - * Zero shifted any number of bits is still zero. - */ - - if ((type1==TCL_NUMBER_LONG) && (*((const long *)ptr1) == (long)0)) { - return constants[0]; - } - - if (opcode == INST_LSHIFT) { - /* - * Large left shifts create integer overflow. - * - * BEWARE! Can't use Tcl_GetIntFromObj() here because that - * converts values in the (unsigned) range to their signed int - * counterparts, leading to incorrect results. - */ - - if ((type2 != TCL_NUMBER_LONG) - || (*((const long *)ptr2) > (long) INT_MAX)) { - /* - * Technically, we could hold the value (1 << (INT_MAX+1)) in - * an mp_int, but since we're using mp_mul_2d() to do the - * work, and it takes only an int argument, that's a good - * place to draw the line. - */ - - Tcl_SetResult(interp, "integer value too large to represent", - TCL_STATIC); - return GENERAL_ARITHMETIC_ERROR; - } - shift = (int)(*((const long *)ptr2)); - - /* - * Handle shifts within the native wide range. - */ - - if ((type1 != TCL_NUMBER_BIG) - && ((size_t)shift < CHAR_BIT*sizeof(Tcl_WideInt))) { - TclGetWideIntFromObj(NULL, valuePtr, &w1); - if (!((w1>0 ? w1 : ~w1) - & -(((Tcl_WideInt)1) - << (CHAR_BIT*sizeof(Tcl_WideInt) - 1 - shift)))) { - WIDE_RESULT(w1 << shift); - } - } - } else { - /* - * Quickly force large right shifts to 0 or -1. - */ - - if ((type2 != TCL_NUMBER_LONG) - || (*(const long *)ptr2 > INT_MAX)) { - /* - * Again, technically, the value to be shifted could be an - * mp_int so huge that a right shift by (INT_MAX+1) bits could - * not take us to the result of 0 or -1, but since we're using - * mp_div_2d to do the work, and it takes only an int - * argument, we draw the line there. - */ - - switch (type1) { - case TCL_NUMBER_LONG: - zero = (*(const long *)ptr1 > 0L); - break; -#ifndef NO_WIDE_TYPE - case TCL_NUMBER_WIDE: - zero = (*(const Tcl_WideInt *)ptr1 > (Tcl_WideInt)0); - break; -#endif - case TCL_NUMBER_BIG: - Tcl_TakeBignumFromObj(NULL, valuePtr, &big1); - zero = (mp_cmp_d(&big1, 0) == MP_GT); - mp_clear(&big1); - break; - default: - /* Unused, here to silence compiler warning. */ - zero = 0; - } - if (zero) { - return constants[0]; - } - LONG_RESULT(-1); - } - shift = (int)(*(const long *)ptr2); - -#ifndef NO_WIDE_TYPE - /* - * Handle shifts within the native wide range. - */ - - if (type1 == TCL_NUMBER_WIDE) { - w1 = *(const Tcl_WideInt *)ptr1; - if ((size_t)shift >= CHAR_BIT*sizeof(Tcl_WideInt)) { - if (w1 >= (Tcl_WideInt)0) { - return constants[0]; - } - LONG_RESULT(-1); - } - WIDE_RESULT(w1 >> shift); - } -#endif - } - - Tcl_TakeBignumFromObj(NULL, valuePtr, &big1); - - mp_init(&bigResult); - if (opcode == INST_LSHIFT) { - mp_mul_2d(&big1, shift, &bigResult); - } else { - mp_init(&bigRemainder); - mp_div_2d(&big1, shift, &bigResult, &bigRemainder); - if (mp_cmp_d(&bigRemainder, 0) == MP_LT) { - /* - * Convert to Tcl's integer division rules. - */ - - mp_sub_d(&bigResult, 1, &bigResult); - } - mp_clear(&bigRemainder); - } - mp_clear(&big1); - BIG_RESULT(&bigResult); +#ifdef TCL_COMPILE_DEBUG + if (traceInstructions) { + fprintf(stdout, " ... found catch at %d, catchTop=%d, unwound to %d, new pc %u\n", + rangePtr->codeOffset, catchTop, catchStackPtr[catchTop], + (unsigned int)(rangePtr->catchOffset)); } +#endif + pc = (codePtr->codeStart + rangePtr->catchOffset); + NEXT_INST_F(0, 0, 0); /* restart the execution loop at pc */ - case INST_BITOR: - case INST_BITXOR: - case INST_BITAND: - if ((type1 == TCL_NUMBER_BIG) || (type2 == TCL_NUMBER_BIG)) { - mp_int *First, *Second; - - Tcl_TakeBignumFromObj(NULL, valuePtr, &big1); - Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2); - - /* - * Count how many positive arguments we have. If only one of the - * arguments is negative, store it in 'Second'. - */ - - if (mp_cmp_d(&big1, 0) != MP_LT) { - numPos = 1 + (mp_cmp_d(&big2, 0) != MP_LT); - First = &big1; - Second = &big2; - } else { - First = &big2; - Second = &big1; - numPos = (mp_cmp_d(First, 0) != MP_LT); - } - mp_init(&bigResult); - - switch (opcode) { - case INST_BITAND: - switch (numPos) { - case 2: - /* - * Both arguments positive, base case. - */ - - mp_and(First, Second, &bigResult); - break; - case 1: - /* - * First is positive; second negative: - * P & N = P & ~~N = P&~(-N-1) = P & (P ^ (-N-1)) - */ - - mp_neg(Second, Second); - mp_sub_d(Second, 1, Second); - mp_xor(First, Second, &bigResult); - mp_and(First, &bigResult, &bigResult); - break; - case 0: - /* - * Both arguments negative: - * a & b = ~ (~a | ~b) = -(-a-1|-b-1)-1 - */ - - mp_neg(First, First); - mp_sub_d(First, 1, First); - mp_neg(Second, Second); - mp_sub_d(Second, 1, Second); - mp_or(First, Second, &bigResult); - mp_neg(&bigResult, &bigResult); - mp_sub_d(&bigResult, 1, &bigResult); - break; - } - break; - - case INST_BITOR: - switch (numPos) { - case 2: - /* - * Both arguments positive, base case. - */ - - mp_or(First, Second, &bigResult); - break; - case 1: - /* - * First is positive; second negative: - * N|P = ~(~N&~P) = ~((-N-1)&~P) = -((-N-1)&((-N-1)^P))-1 - */ - - mp_neg(Second, Second); - mp_sub_d(Second, 1, Second); - mp_xor(First, Second, &bigResult); - mp_and(Second, &bigResult, &bigResult); - mp_neg(&bigResult, &bigResult); - mp_sub_d(&bigResult, 1, &bigResult); - break; - case 0: - /* - * Both arguments negative: - * a | b = ~ (~a & ~b) = -(-a-1&-b-1)-1 - */ - - mp_neg(First, First); - mp_sub_d(First, 1, First); - mp_neg(Second, Second); - mp_sub_d(Second, 1, Second); - mp_and(First, Second, &bigResult); - mp_neg(&bigResult, &bigResult); - mp_sub_d(&bigResult, 1, &bigResult); - break; - } - break; - - case INST_BITXOR: - switch (numPos) { - case 2: - /* - * Both arguments positive, base case. - */ - - mp_xor(First, Second, &bigResult); - break; - case 1: - /* - * First is positive; second negative: - * P^N = ~(P^~N) = -(P^(-N-1))-1 - */ - - mp_neg(Second, Second); - mp_sub_d(Second, 1, Second); - mp_xor(First, Second, &bigResult); - mp_neg(&bigResult, &bigResult); - mp_sub_d(&bigResult, 1, &bigResult); - break; - case 0: - /* - * Both arguments negative: - * a ^ b = (~a ^ ~b) = (-a-1^-b-1) - */ - - mp_neg(First, First); - mp_sub_d(First, 1, First); - mp_neg(Second, Second); - mp_sub_d(Second, 1, Second); - mp_xor(First, Second, &bigResult); - break; - } - break; - } - - mp_clear(&big1); - mp_clear(&big2); - BIG_RESULT(&bigResult); - } - -#ifndef NO_WIDE_TYPE - if ((type1 == TCL_NUMBER_WIDE) || (type2 == TCL_NUMBER_WIDE)) { - TclGetWideIntFromObj(NULL, valuePtr, &w1); - TclGetWideIntFromObj(NULL, value2Ptr, &w2); - - switch (opcode) { - case INST_BITAND: - wResult = w1 & w2; - break; - case INST_BITOR: - wResult = w1 | w2; - break; - case INST_BITXOR: - wResult = w1 ^ w2; - break; - default: - /* Unused, here to silence compiler warning. */ - wResult = 0; - } - WIDE_RESULT(wResult); - } -#endif - l1 = *((const long *)ptr1); - l2 = *((const long *)ptr2); - - switch (opcode) { - case INST_BITAND: - lResult = l1 & l2; - break; - case INST_BITOR: - lResult = l1 | l2; - break; - case INST_BITXOR: - lResult = l1 ^ l2; - break; - default: - /* Unused, here to silence compiler warning. */ - lResult = 0; - } - LONG_RESULT(lResult); - - case INST_EXPON: { - int oddExponent = 0, negativeExponent = 0; - unsigned short base; - - if ((type1 == TCL_NUMBER_DOUBLE) || (type2 == TCL_NUMBER_DOUBLE)) { - Tcl_GetDoubleFromObj(NULL, valuePtr, &d1); - Tcl_GetDoubleFromObj(NULL, value2Ptr, &d2); - - if (d1==0.0 && d2<0.0) { - return EXPONENT_OF_ZERO; - } - dResult = pow(d1, d2); - goto doubleResult; - } - l1 = l2 = 0; - if (type2 == TCL_NUMBER_LONG) { - l2 = *((const long *) ptr2); - if (l2 == 0) { - /* - * Anything to the zero power is 1. - */ - - return constants[1]; - } else if (l2 == 1) { - /* - * Anything to the first power is itself - */ - - return NULL; - } - } - - switch (type2) { - case TCL_NUMBER_LONG: - negativeExponent = (l2 < 0); - oddExponent = (int) (l2 & 1); - break; -#ifndef NO_WIDE_TYPE - case TCL_NUMBER_WIDE: - w2 = *((const Tcl_WideInt *)ptr2); - negativeExponent = (w2 < 0); - oddExponent = (int) (w2 & (Tcl_WideInt)1); - break; -#endif - case TCL_NUMBER_BIG: - Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2); - negativeExponent = (mp_cmp_d(&big2, 0) == MP_LT); - mp_mod_2d(&big2, 1, &big2); - oddExponent = !mp_iszero(&big2); - mp_clear(&big2); - break; - } - - if (type1 == TCL_NUMBER_LONG) { - l1 = *((const long *)ptr1); - } - if (negativeExponent) { - if (type1 == TCL_NUMBER_LONG) { - switch (l1) { - case 0: - /* - * Zero to a negative power is div by zero error. - */ - - return EXPONENT_OF_ZERO; - case -1: - if (oddExponent) { - LONG_RESULT(-1); - } - /* fallthrough */ - case 1: - /* - * 1 to any power is 1. - */ - - return constants[1]; - } - } - - /* - * Integers with magnitude greater than 1 raise to a negative - * power yield the answer zero (see TIP 123). - */ - - return constants[0]; - } - - if (type1 == TCL_NUMBER_LONG) { - switch (l1) { - case 0: - /* - * Zero to a positive power is zero. - */ - - return constants[0]; - case 1: - /* - * 1 to any power is 1. - */ - - return constants[1]; - case -1: - if (!oddExponent) { - return constants[1]; - } - LONG_RESULT(-1); - } - } - - /* - * We refuse to accept exponent arguments that exceed one mp_digit - * which means the max exponent value is 2**28-1 = 0x0fffffff = - * 268435455, which fits into a signed 32 bit int which is within the - * range of the long int type. This means any numeric Tcl_Obj value - * not using TCL_NUMBER_LONG type must hold a value larger than we - * accept. - */ - - if (type2 != TCL_NUMBER_LONG) { - Tcl_SetResult(interp, "exponent too large", TCL_STATIC); - return GENERAL_ARITHMETIC_ERROR; - } - - if (type1 == TCL_NUMBER_LONG) { - if (l1 == 2) { - /* - * Reduce small powers of 2 to shifts. - */ - - if ((unsigned long) l2 < CHAR_BIT * sizeof(long) - 1) { - LONG_RESULT(1L << l2); - } -#if !defined(TCL_WIDE_INT_IS_LONG) - if ((unsigned long)l2 < CHAR_BIT*sizeof(Tcl_WideInt) - 1) { - WIDE_RESULT(((Tcl_WideInt) 1) << l2); - } -#endif - goto overflowExpon; - } - if (l1 == -2) { - int signum = oddExponent ? -1 : 1; - - /* - * Reduce small powers of 2 to shifts. - */ - - if ((unsigned long) l2 < CHAR_BIT * sizeof(long) - 1) { - LONG_RESULT(signum * (1L << l2)); - } -#if !defined(TCL_WIDE_INT_IS_LONG) - if ((unsigned long)l2 < CHAR_BIT*sizeof(Tcl_WideInt) - 1){ - WIDE_RESULT(signum * (((Tcl_WideInt) 1) << l2)); - } -#endif - goto overflowExpon; - } -#if (LONG_MAX == 0x7fffffff) - if (l2 - 2 < (long)MaxBase32Size - && l1 <= MaxBase32[l2 - 2] - && l1 >= -MaxBase32[l2 - 2]) { - /* - * Small powers of 32-bit integers. - */ - - lResult = l1 * l1; /* b**2 */ - switch (l2) { - case 2: - break; - case 3: - lResult *= l1; /* b**3 */ - break; - case 4: - lResult *= lResult; /* b**4 */ - break; - case 5: - lResult *= lResult; /* b**4 */ - lResult *= l1; /* b**5 */ - break; - case 6: - lResult *= l1; /* b**3 */ - lResult *= lResult; /* b**6 */ - break; - case 7: - lResult *= l1; /* b**3 */ - lResult *= lResult; /* b**6 */ - lResult *= l1; /* b**7 */ - break; - case 8: - lResult *= lResult; /* b**4 */ - lResult *= lResult; /* b**8 */ - break; - } - LONG_RESULT(lResult); - } - - if (l1 - 3 >= 0 && l1 -2 < (long)Exp32IndexSize - && l2 - 2 < (long)(Exp32ValueSize + MaxBase32Size)) { - base = Exp32Index[l1 - 3] - + (unsigned short) (l2 - 2 - MaxBase32Size); - if (base < Exp32Index[l1 - 2]) { - /* - * 32-bit number raised to intermediate power, done by - * table lookup. - */ - - LONG_RESULT(Exp32Value[base]); - } - } - if (-l1 - 3 >= 0 && -l1 - 2 < (long)Exp32IndexSize - && l2 - 2 < (long)(Exp32ValueSize + MaxBase32Size)) { - base = Exp32Index[-l1 - 3] - + (unsigned short) (l2 - 2 - MaxBase32Size); - if (base < Exp32Index[-l1 - 2]) { - /* - * 32-bit number raised to intermediate power, done by - * table lookup. - */ - - lResult = (oddExponent) ? - -Exp32Value[base] : Exp32Value[base]; - LONG_RESULT(lResult); - } - } -#endif - } -#if (LONG_MAX > 0x7fffffff) || !defined(TCL_WIDE_INT_IS_LONG) - if (type1 == TCL_NUMBER_LONG) { - w1 = l1; -#ifndef NO_WIDE_TYPE - } else if (type1 == TCL_NUMBER_WIDE) { - w1 = *((const Tcl_WideInt *) ptr1); -#endif - } else { - goto overflowExpon; - } - if (l2 - 2 < (long)MaxBase64Size - && w1 <= MaxBase64[l2 - 2] - && w1 >= -MaxBase64[l2 - 2]) { - /* - * Small powers of integers whose result is wide. - */ - - wResult = w1 * w1; /* b**2 */ - switch (l2) { - case 2: - break; - case 3: - wResult *= l1; /* b**3 */ - break; - case 4: - wResult *= wResult; /* b**4 */ - break; - case 5: - wResult *= wResult; /* b**4 */ - wResult *= w1; /* b**5 */ - break; - case 6: - wResult *= w1; /* b**3 */ - wResult *= wResult; /* b**6 */ - break; - case 7: - wResult *= w1; /* b**3 */ - wResult *= wResult; /* b**6 */ - wResult *= w1; /* b**7 */ - break; - case 8: - wResult *= wResult; /* b**4 */ - wResult *= wResult; /* b**8 */ - break; - case 9: - wResult *= wResult; /* b**4 */ - wResult *= wResult; /* b**8 */ - wResult *= w1; /* b**9 */ - break; - case 10: - wResult *= wResult; /* b**4 */ - wResult *= w1; /* b**5 */ - wResult *= wResult; /* b**10 */ - break; - case 11: - wResult *= wResult; /* b**4 */ - wResult *= w1; /* b**5 */ - wResult *= wResult; /* b**10 */ - wResult *= w1; /* b**11 */ - break; - case 12: - wResult *= w1; /* b**3 */ - wResult *= wResult; /* b**6 */ - wResult *= wResult; /* b**12 */ - break; - case 13: - wResult *= w1; /* b**3 */ - wResult *= wResult; /* b**6 */ - wResult *= wResult; /* b**12 */ - wResult *= w1; /* b**13 */ - break; - case 14: - wResult *= w1; /* b**3 */ - wResult *= wResult; /* b**6 */ - wResult *= w1; /* b**7 */ - wResult *= wResult; /* b**14 */ - break; - case 15: - wResult *= w1; /* b**3 */ - wResult *= wResult; /* b**6 */ - wResult *= w1; /* b**7 */ - wResult *= wResult; /* b**14 */ - wResult *= w1; /* b**15 */ - break; - case 16: - wResult *= wResult; /* b**4 */ - wResult *= wResult; /* b**8 */ - wResult *= wResult; /* b**16 */ - break; - } - WIDE_RESULT(wResult); - } - - /* - * Handle cases of powers > 16 that still fit in a 64-bit word by - * doing table lookup. - */ - - if (w1 - 3 >= 0 && w1 - 2 < (long)Exp64IndexSize - && l2 - 2 < (long)(Exp64ValueSize + MaxBase64Size)) { - base = Exp64Index[w1 - 3] - + (unsigned short) (l2 - 2 - MaxBase64Size); - if (base < Exp64Index[w1 - 2]) { - /* - * 64-bit number raised to intermediate power, done by - * table lookup. - */ - - WIDE_RESULT(Exp64Value[base]); - } - } - - if (-w1 - 3 >= 0 && -w1 - 2 < (long)Exp64IndexSize - && l2 - 2 < (long)(Exp64ValueSize + MaxBase64Size)) { - base = Exp64Index[-w1 - 3] - + (unsigned short) (l2 - 2 - MaxBase64Size); - if (base < Exp64Index[-w1 - 2]) { - /* - * 64-bit number raised to intermediate power, done by - * table lookup. - */ + /* + * end of infinite loop dispatching on instructions. + */ - wResult = oddExponent ? -Exp64Value[base] : Exp64Value[base]; - WIDE_RESULT(wResult); - } - } -#endif + /* + * Abnormal return code. Restore the stack to state it had when starting + * to execute the ByteCode. Panic if the stack is below the initial level. + */ - overflowExpon: - Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2); - if (big2.used > 1) { - mp_clear(&big2); - Tcl_SetResult(interp, "exponent too large", TCL_STATIC); - return GENERAL_ARITHMETIC_ERROR; - } - Tcl_TakeBignumFromObj(NULL, valuePtr, &big1); - mp_init(&bigResult); - mp_expt_d(&big1, big2.dp[0], &bigResult); - mp_clear(&big1); - mp_clear(&big2); - BIG_RESULT(&bigResult); + abnormalReturn: + TCL_DTRACE_INST_LAST(); + while (stackTop > initStackTop) { + valuePtr = POP_OBJECT(); + TclDecrRefCount(valuePtr); } - - case INST_ADD: - case INST_SUB: - case INST_MULT: - case INST_DIV: - if ((type1 == TCL_NUMBER_DOUBLE) || (type2 == TCL_NUMBER_DOUBLE)) { - /* - * At least one of the values is floating-point, so perform - * floating point calculations. - */ - - Tcl_GetDoubleFromObj(NULL, valuePtr, &d1); - Tcl_GetDoubleFromObj(NULL, value2Ptr, &d2); - - 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: -#ifndef IEEE_FLOATING_POINT - if (d2 == 0.0) { - return DIVIDED_BY_ZERO; - } -#endif - /* - * We presume that we are running with zero-divide unmasked if - * we're on an IEEE box. Otherwise, this statement might cause - * demons to fly out our noses. - */ - - dResult = d1 / d2; - break; - default: - /* Unused, here to silence compiler warning. */ - dResult = 0; - } - - doubleResult: -#ifndef ACCEPT_NAN - /* - * Check now for IEEE floating-point error. - */ - - if (TclIsNaN(dResult)) { - TclExprFloatError(interp, dResult); - return GENERAL_ARITHMETIC_ERROR; - } -#endif - DOUBLE_RESULT(dResult); - } - if ((type1 != TCL_NUMBER_BIG) && (type2 != TCL_NUMBER_BIG)) { - TclGetWideIntFromObj(NULL, valuePtr, &w1); - TclGetWideIntFromObj(NULL, value2Ptr, &w2); - - switch (opcode) { - case INST_ADD: - wResult = w1 + w2; -#ifndef NO_WIDE_TYPE - if ((type1 == TCL_NUMBER_WIDE) || (type2 == TCL_NUMBER_WIDE)) -#endif - { - /* - * Check for overflow. - */ - - if (Overflowing(w1, w2, wResult)) { - goto overflowBasic; - } - } - break; - - case INST_SUB: - wResult = w1 - w2; -#ifndef NO_WIDE_TYPE - if ((type1 == TCL_NUMBER_WIDE) || (type2 == TCL_NUMBER_WIDE)) -#endif - { - /* - * Must check for overflow. The macro tests for overflows - * in sums by looking at the sign bits. As we have a - * subtraction here, we are adding -w2. As -w2 could in - * turn overflow, we test with ~w2 instead: it has the - * opposite sign bit to w2 so it does the job. Note that - * the only "bad" case (w2==0) is irrelevant for this - * macro, as in that case w1 and wResult have the same - * sign and there is no overflow anyway. - */ - - if (Overflowing(w1, ~w2, wResult)) { - goto overflowBasic; - } - } - break; - - case INST_MULT: - if ((type1 != TCL_NUMBER_LONG) || (type2 != TCL_NUMBER_LONG) - || (sizeof(Tcl_WideInt) < 2*sizeof(long))) { - goto overflowBasic; - } - wResult = w1 * w2; - break; - - case INST_DIV: - if (w2 == 0) { - return DIVIDED_BY_ZERO; - } - - /* - * Need a bignum to represent (LLONG_MIN / -1) - */ - - if ((w1 == LLONG_MIN) && (w2 == -1)) { - goto overflowBasic; - } - wResult = w1 / w2; - - /* - * Force Tcl's integer division rules. - * TODO: examine for logic simplification - */ - - if (((wResult < 0) || ((wResult == 0) && - ((w1 < 0 && w2 > 0) || (w1 > 0 && w2 < 0)))) && - (wResult*w2 != w1)) { - wResult -= 1; - } - break; - - default: - /* - * Unused, here to silence compiler warning. - */ - - wResult = 0; - } - - WIDE_RESULT(wResult); - } - - overflowBasic: - Tcl_TakeBignumFromObj(NULL, valuePtr, &big1); - Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2); - mp_init(&bigResult); - switch (opcode) { - case INST_ADD: - mp_add(&big1, &big2, &bigResult); - break; - case INST_SUB: - mp_sub(&big1, &big2, &bigResult); - break; - case INST_MULT: - mp_mul(&big1, &big2, &bigResult); - break; - case INST_DIV: - if (mp_iszero(&big2)) { - mp_clear(&big1); - mp_clear(&big2); - mp_clear(&bigResult); - return DIVIDED_BY_ZERO; - } - mp_init(&bigRemainder); - mp_div(&big1, &big2, &bigResult, &bigRemainder); - /* TODO: internals intrusion */ - if (!mp_iszero(&bigRemainder) - && (bigRemainder.sign != big2.sign)) { - /* - * Convert to Tcl's integer division rules. - */ - - mp_sub_d(&bigResult, 1, &bigResult); - mp_add(&bigRemainder, &big2, &bigRemainder); - } - mp_clear(&bigRemainder); - break; - } - mp_clear(&big1); - mp_clear(&big2); - BIG_RESULT(&bigResult); + if (stackTop < initStackTop) { + fprintf(stderr, "\nTclExecuteByteCode: abnormal return at pc %u: stack top %d < entry stack top %d\n", + (unsigned int)(pc - codePtr->codeStart), + (unsigned int) stackTop, + (unsigned int) initStackTop); + panic("TclExecuteByteCode execution failure: end stack top < start stack top"); } + + /* + * Free the catch stack array if malloc'ed storage was used. + */ - Tcl_Panic("unexpected opcode"); - return NULL; -} - -static Tcl_Obj * -ExecuteExtendedUnaryMathOp( - int opcode, /* What operation to perform. */ - Tcl_Obj *valuePtr) /* The operand on the stack. */ -{ - ClientData ptr; - int type; - Tcl_WideInt w; - mp_int big; - Tcl_Obj *objResultPtr; - - (void) GetNumberFromObj(NULL, valuePtr, &ptr, &type); - - switch (opcode) { - case INST_BITNOT: -#ifndef NO_WIDE_TYPE - if (type == TCL_NUMBER_WIDE) { - w = *((const Tcl_WideInt *) ptr); - WIDE_RESULT(~w); - } -#endif - Tcl_TakeBignumFromObj(NULL, valuePtr, &big); - /* ~a = - a - 1 */ - mp_neg(&big, &big); - mp_sub_d(&big, 1, &big); - BIG_RESULT(&big); - case INST_UMINUS: - switch (type) { - case TCL_NUMBER_DOUBLE: - DOUBLE_RESULT(-(*((const double *) ptr))); - case TCL_NUMBER_LONG: - w = (Tcl_WideInt) (*((const long *) ptr)); - if (w != LLONG_MIN) { - WIDE_RESULT(-w); - } - TclBNInitBignumFromLong(&big, *(const long *) ptr); - break; -#ifndef NO_WIDE_TYPE - case TCL_NUMBER_WIDE: - w = *((const Tcl_WideInt *) ptr); - if (w != LLONG_MIN) { - WIDE_RESULT(-w); - } - TclBNInitBignumFromWideInt(&big, w); - break; -#endif - default: - Tcl_TakeBignumFromObj(NULL, valuePtr, &big); - } - mp_neg(&big, &big); - BIG_RESULT(&big); + if (catchStackPtr != catchStackStorage) { + ckfree((char *) catchStackPtr); } + eePtr->stackTop = initStackTop; - Tcl_Panic("unexpected opcode"); - return NULL; -} -#undef LONG_RESULT -#undef WIDE_RESULT -#undef BIG_RESULT -#undef DOUBLE_RESULT - -/* - *---------------------------------------------------------------------- - * - * CompareTwoNumbers -- - * - * This function compares a pair of numbers in Tcl_Objs. Each argument - * must already be known to be numeric and not NaN. - * - * Results: - * One of MP_LT, MP_EQ or MP_GT, depending on whether valuePtr is less - * than, equal to, or greater than value2Ptr (respectively). - * - * Side effects: - * None, provided both values are numeric. - * - *---------------------------------------------------------------------- - */ - -int -TclCompareTwoNumbers( - Tcl_Obj *valuePtr, - Tcl_Obj *value2Ptr) -{ - int type1, type2, compare; - ClientData ptr1, ptr2; - mp_int big1, big2; - double d1, d2, tmp; - long l1, l2; -#ifndef NO_WIDE_TYPE - Tcl_WideInt w1, w2; -#endif - - (void) GetNumberFromObj(NULL, valuePtr, &ptr1, &type1); - (void) GetNumberFromObj(NULL, value2Ptr, &ptr2, &type2); - - switch (type1) { - case TCL_NUMBER_LONG: - l1 = *((const long *)ptr1); - switch (type2) { - case TCL_NUMBER_LONG: - l2 = *((const long *)ptr2); - longCompare: - return (l1 < l2) ? MP_LT : ((l1 > l2) ? MP_GT : MP_EQ); -#ifndef NO_WIDE_TYPE - case TCL_NUMBER_WIDE: - w2 = *((const Tcl_WideInt *)ptr2); - w1 = (Tcl_WideInt)l1; - goto wideCompare; -#endif - case TCL_NUMBER_DOUBLE: - d2 = *((const double *)ptr2); - d1 = (double) l1; - - /* - * If the double has a fractional part, or if the long can be - * converted to double without loss of precision, then compare as - * doubles. - */ - - if (DBL_MANT_DIG > CHAR_BIT*sizeof(long) || l1 == (long) d1 - || modf(d2, &tmp) != 0.0) { - goto doubleCompare; - } - - /* - * Otherwise, to make comparision based on full precision, need to - * convert the double to a suitably sized integer. - * - * Need this to get comparsions like - * expr 20000000000000003 < 20000000000000004.0 - * right. Converting the first argument to double will yield two - * double values that are equivalent within double precision. - * Converting the double to an integer gets done exactly, then - * integer comparison can tell the difference. - */ - - if (d2 < (double)LONG_MIN) { - return MP_GT; - } - if (d2 > (double)LONG_MAX) { - return MP_LT; - } - l2 = (long) d2; - goto longCompare; - case TCL_NUMBER_BIG: - Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2); - if (mp_cmp_d(&big2, 0) == MP_LT) { - compare = MP_GT; - } else { - compare = MP_LT; - } - mp_clear(&big2); - return compare; - } - -#ifndef NO_WIDE_TYPE - case TCL_NUMBER_WIDE: - w1 = *((const Tcl_WideInt *)ptr1); - switch (type2) { - case TCL_NUMBER_WIDE: - w2 = *((const Tcl_WideInt *)ptr2); - wideCompare: - return (w1 < w2) ? MP_LT : ((w1 > w2) ? MP_GT : MP_EQ); - case TCL_NUMBER_LONG: - l2 = *((const long *)ptr2); - w2 = (Tcl_WideInt)l2; - goto wideCompare; - case TCL_NUMBER_DOUBLE: - d2 = *((const double *)ptr2); - d1 = (double) w1; - if (DBL_MANT_DIG > CHAR_BIT*sizeof(Tcl_WideInt) - || w1 == (Tcl_WideInt) d1 || modf(d2, &tmp) != 0.0) { - goto doubleCompare; - } - if (d2 < (double)LLONG_MIN) { - return MP_GT; - } - if (d2 > (double)LLONG_MAX) { - return MP_LT; - } - w2 = (Tcl_WideInt) d2; - goto wideCompare; - case TCL_NUMBER_BIG: - Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2); - if (mp_cmp_d(&big2, 0) == MP_LT) { - compare = MP_GT; - } else { - compare = MP_LT; - } - mp_clear(&big2); - return compare; - } -#endif - - case TCL_NUMBER_DOUBLE: - d1 = *((const double *)ptr1); - switch (type2) { - case TCL_NUMBER_DOUBLE: - d2 = *((const double *)ptr2); - doubleCompare: - return (d1 < d2) ? MP_LT : ((d1 > d2) ? MP_GT : MP_EQ); - case TCL_NUMBER_LONG: - l2 = *((const long *)ptr2); - d2 = (double) l2; - if (DBL_MANT_DIG > CHAR_BIT*sizeof(long) || l2 == (long) d2 - || modf(d1, &tmp) != 0.0) { - goto doubleCompare; - } - if (d1 < (double)LONG_MIN) { - return MP_LT; - } - if (d1 > (double)LONG_MAX) { - return MP_GT; - } - l1 = (long) d1; - goto longCompare; -#ifndef NO_WIDE_TYPE - case TCL_NUMBER_WIDE: - w2 = *((const Tcl_WideInt *)ptr2); - d2 = (double) w2; - if (DBL_MANT_DIG > CHAR_BIT*sizeof(Tcl_WideInt) - || w2 == (Tcl_WideInt) d2 || modf(d1, &tmp) != 0.0) { - goto doubleCompare; - } - if (d1 < (double)LLONG_MIN) { - return MP_LT; - } - if (d1 > (double)LLONG_MAX) { - return MP_GT; - } - w1 = (Tcl_WideInt) d1; - goto wideCompare; -#endif - case TCL_NUMBER_BIG: - if (TclIsInfinite(d1)) { - return (d1 > 0.0) ? MP_GT : MP_LT; - } - Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2); - if ((d1 < (double)LONG_MAX) && (d1 > (double)LONG_MIN)) { - if (mp_cmp_d(&big2, 0) == MP_LT) { - compare = MP_GT; - } else { - compare = MP_LT; - } - mp_clear(&big2); - return compare; - } - if (DBL_MANT_DIG > CHAR_BIT*sizeof(long) - && modf(d1, &tmp) != 0.0) { - d2 = TclBignumToDouble(&big2); - mp_clear(&big2); - goto doubleCompare; - } - Tcl_InitBignumFromDouble(NULL, d1, &big1); - goto bigCompare; - } - - case TCL_NUMBER_BIG: - Tcl_TakeBignumFromObj(NULL, valuePtr, &big1); - switch (type2) { -#ifndef NO_WIDE_TYPE - case TCL_NUMBER_WIDE: -#endif - case TCL_NUMBER_LONG: - compare = mp_cmp_d(&big1, 0); - mp_clear(&big1); - return compare; - case TCL_NUMBER_DOUBLE: - d2 = *((const double *)ptr2); - if (TclIsInfinite(d2)) { - compare = (d2 > 0.0) ? MP_LT : MP_GT; - mp_clear(&big1); - return compare; - } - if ((d2 < (double)LONG_MAX) && (d2 > (double)LONG_MIN)) { - compare = mp_cmp_d(&big1, 0); - mp_clear(&big1); - return compare; - } - if (DBL_MANT_DIG > CHAR_BIT*sizeof(long) - && modf(d2, &tmp) != 0.0) { - d1 = TclBignumToDouble(&big1); - mp_clear(&big1); - goto doubleCompare; - } - Tcl_InitBignumFromDouble(NULL, d2, &big2); - goto bigCompare; - case TCL_NUMBER_BIG: - Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2); - bigCompare: - compare = mp_cmp(&big1, &big2); - mp_clear(&big1); - mp_clear(&big2); - return compare; - } - default: - Tcl_Panic("unexpected number type"); - return TCL_ERROR; - } + return result; +#undef STATIC_CATCH_STACK_SIZE } #ifdef TCL_COMPILE_DEBUG @@ -7871,9 +4537,9 @@ TclCompareTwoNumbers( * * PrintByteCodeInfo -- * - * This procedure prints a summary about a bytecode object to stdout. It - * is called by TclNRExecuteByteCode when starting to execute the bytecode - * object if tclTraceExec has the value 2 or more. + * 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. @@ -7885,45 +4551,46 @@ TclCompareTwoNumbers( */ static void -PrintByteCodeInfo( - register ByteCode *codePtr) /* The bytecode whose summary is printed to - * stdout. */ +PrintByteCodeInfo(codePtr) + register ByteCode *codePtr; /* The bytecode whose summary is printed + * to stdout. */ { Proc *procPtr = codePtr->procPtr; Interp *iPtr = (Interp *) *codePtr->interpHandle; - fprintf(stdout, "\nExecuting ByteCode 0x%p, refCt %u, epoch %u, interp 0x%p (epoch %u)\n", - codePtr, codePtr->refCount, codePtr->compileEpoch, iPtr, + fprintf(stdout, "\nExecuting ByteCode 0x%x, refCt %u, epoch %u, interp 0x%x (epoch %u)\n", + (unsigned int) codePtr, codePtr->refCount, + codePtr->compileEpoch, (unsigned int) iPtr, iPtr->compileEpoch); - + fprintf(stdout, " Source: "); TclPrintSource(stdout, codePtr->source, 60); fprintf(stdout, "\n Cmds %d, src %d, inst %u, litObjs %u, aux %d, stkDepth %u, code/src %.2f\n", - codePtr->numCommands, codePtr->numSrcBytes, + codePtr->numCommands, codePtr->numSrcBytes, codePtr->numCodeBytes, codePtr->numLitObjects, codePtr->numAuxDataItems, codePtr->maxStackDepth, #ifdef TCL_COMPILE_STATS - codePtr->numSrcBytes? - ((float)codePtr->structureSize)/codePtr->numSrcBytes : -#endif + (codePtr->numSrcBytes? + ((float)codePtr->structureSize)/((float)codePtr->numSrcBytes) : 0.0)); +#else 0.0); - +#endif #ifdef TCL_COMPILE_STATS - fprintf(stdout, " Code %lu = header %lu+inst %d+litObj %lu+exc %lu+aux %lu+cmdMap %d\n", - (unsigned long) codePtr->structureSize, - (unsigned long) (sizeof(ByteCode)-sizeof(size_t)-sizeof(Tcl_Time)), + fprintf(stdout, " Code %u = header %u+inst %d+litObj %lu+exc %lu+aux %lu+cmdMap %d\n", + (unsigned int)codePtr->structureSize, + (unsigned int)(sizeof(ByteCode) - (sizeof(size_t) + sizeof(Tcl_Time))), codePtr->numCodeBytes, - (unsigned long) (codePtr->numLitObjects * sizeof(Tcl_Obj *)), - (unsigned long) (codePtr->numExceptRanges*sizeof(ExceptionRange)), - (unsigned long) (codePtr->numAuxDataItems * sizeof(AuxData)), + (unsigned long)(codePtr->numLitObjects * sizeof(Tcl_Obj *)), + (unsigned long)(codePtr->numExceptRanges * sizeof(ExceptionRange)), + (unsigned long)(codePtr->numAuxDataItems * sizeof(AuxData)), codePtr->numCmdLocBytes); #endif /* TCL_COMPILE_STATS */ if (procPtr != NULL) { fprintf(stdout, - " Proc 0x%p, refCt %d, args %d, compiled locals %d\n", - procPtr, procPtr->refCount, procPtr->numArgs, - procPtr->numCompiledLocals); + " Proc 0x%x, refCt %d, args %d, compiled locals %d\n", + (unsigned int) procPtr, procPtr->refCount, + procPtr->numArgs, procPtr->numCompiledLocals); } } #endif /* TCL_COMPILE_DEBUG */ @@ -7933,7 +4600,7 @@ PrintByteCodeInfo( * * ValidatePcAndStackTop -- * - * This procedure is called by TclNRExecuteByteCode when debugging to + * This procedure is called by TclExecuteByteCode when debugging to * verify that the program counter and stack top are valid during * execution. * @@ -7941,63 +4608,60 @@ PrintByteCodeInfo( * None. * * Side effects: - * Prints a message to stderr and panics if either the pc or stack top - * are invalid. + * Prints a message to stderr and panics if either the pc or stack + * top are invalid. * *---------------------------------------------------------------------- */ #ifdef TCL_COMPILE_DEBUG static void -ValidatePcAndStackTop( - register ByteCode *codePtr, /* The bytecode whose summary is printed to - * stdout. */ - const unsigned char *pc, /* Points to first byte of a bytecode +ValidatePcAndStackTop(codePtr, pc, stackTop, stackLowerBound) + 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 + int stackTop; /* Current stack top. Must be between * stackLowerBound and stackUpperBound * (inclusive). */ - int stackLowerBound, /* Smallest legal value for stackTop. */ - int checkStack) /* 0 if the stack depth check should be - * skipped. */ + int stackLowerBound; /* Smallest legal value for stackTop. */ { - int stackUpperBound = stackLowerBound + codePtr->maxStackDepth; - /* Greatest legal value for stackTop. */ - unsigned relativePc = (unsigned) (pc - codePtr->codeStart); - unsigned long codeStart = (unsigned long) codePtr->codeStart; - unsigned long codeEnd = (unsigned long) + int stackUpperBound = stackLowerBound + codePtr->maxStackDepth; + /* 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 long) pc < codeStart) || ((unsigned long) pc > codeEnd)) { - fprintf(stderr, "\nBad instruction pc 0x%p in TclNRExecuteByteCode\n", - pc); - Tcl_Panic("TclNRExecuteByteCode execution failure: bad 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) opCode > LAST_INST_OPCODE) { - fprintf(stderr, "\nBad opcode %d at pc %u in TclNRExecuteByteCode\n", - (unsigned) opCode, relativePc); - Tcl_Panic("TclNRExecuteByteCode execution failure: bad opcode"); + 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 (checkStack && - ((stackTop < stackLowerBound) || (stackTop > stackUpperBound))) { + if ((stackTop < stackLowerBound) || (stackTop > stackUpperBound)) { int numChars; - const char *cmd = GetSrcInfoForPc(pc, codePtr, &numChars, NULL); - - fprintf(stderr, "\nBad stack top %d at pc %u in TclNRExecuteByteCode (min %i, max %i)", + char *cmd = GetSrcInfoForPc(pc, codePtr, &numChars); + char *ellipsis = ""; + + fprintf(stderr, "\nBad stack top %d at pc %u in TclExecuteByteCode (min %i, max %i)", stackTop, relativePc, stackLowerBound, stackUpperBound); if (cmd != NULL) { - Tcl_Obj *message; - - TclNewLiteralStringObj(message, "\n executing "); - Tcl_IncrRefCount(message); - Tcl_AppendLimitedToObj(message, cmd, numChars, 100, NULL); - fprintf(stderr,"%s\n", Tcl_GetString(message)); - Tcl_DecrRefCount(message); + if (numChars > 100) { + numChars = 100; + ellipsis = "..."; + } + fprintf(stderr, "\n executing %.*s%s\n", numChars, cmd, + ellipsis); } else { fprintf(stderr, "\n"); } - Tcl_Panic("TclNRExecuteByteCode execution failure: bad stack top"); + panic("TclExecuteByteCode execution failure: bad stack top"); } } #endif /* TCL_COMPILE_DEBUG */ @@ -8007,66 +4671,142 @@ ValidatePcAndStackTop( * * IllegalExprOperandType -- * - * Used by TclNRExecuteByteCode to append an error message to the interp - * result when an illegal operand type is detected by an expression + * Used by TclExecuteByteCode to add an error message to errorInfo + * when an illegal operand type is detected by an expression * instruction. The argument opndPtr holds the operand object in error. * * Results: * None. * * Side effects: - * An error message is appended to the interp result. + * An error message is appended to errorInfo. * *---------------------------------------------------------------------- */ static void -IllegalExprOperandType( - Tcl_Interp *interp, /* Interpreter to which error information +IllegalExprOperandType(interp, pc, opndPtr) + Tcl_Interp *interp; /* Interpreter to which error information * pertains. */ - const unsigned char *pc, /* Points to the instruction being executed + unsigned char *pc; /* Points to the instruction being executed * when the illegal type was found. */ - Tcl_Obj *opndPtr) /* Points to the operand holding the value + Tcl_Obj *opndPtr; /* Points to the operand holding the value * with the illegal type. */ { - ClientData ptr; - int type; - const unsigned char opcode = *pc; - const char *description, *operator = operatorStrings[opcode - INST_LOR]; + unsigned char opCode = *pc; + + 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 { + char *msg = "non-numeric string"; + char *s, *p; + int length; + int looksLikeInt = 0; - if (opcode == INST_EXPON) { - operator = "**"; - } + s = Tcl_GetStringFromObj(opndPtr, &length); + p = s; + /* + * strtod() isn't at all consistent about detecting Inf and + * NaN between platforms. + */ + if (length == 3) { + if ((s[0]=='n' || s[0]=='N') && (s[1]=='a' || s[1]=='A') && + (s[2]=='n' || s[2]=='N')) { + msg = "non-numeric floating-point value"; + goto makeErrorMessage; + } + if ((s[0]=='i' || s[0]=='I') && (s[1]=='n' || s[1]=='N') && + (s[2]=='f' || s[2]=='F')) { + msg = "infinite floating-point value"; + goto makeErrorMessage; + } + } + + /* + * We cannot use TclLooksLikeInt here because it passes strings + * like "10;" [Bug 587140]. We'll accept as "looking like ints" + * for the present purposes any string that looks formally like + * a (decimal|octal|hex) integer. + */ - if (GetNumberFromObj(NULL, opndPtr, &ptr, &type) != TCL_OK) { - int numBytes; - const char *bytes = Tcl_GetStringFromObj(opndPtr, &numBytes); + while (length && isspace(UCHAR(*p))) { + length--; + p++; + } + if (length && ((*p == '+') || (*p == '-'))) { + length--; + p++; + } + if (length) { + if ((*p == '0') && ((*(p+1) == 'x') || (*(p+1) == 'X'))) { + p += 2; + length -= 2; + looksLikeInt = ((length > 0) && isxdigit(UCHAR(*p))); + if (looksLikeInt) { + length--; + p++; + while (length && isxdigit(UCHAR(*p))) { + length--; + p++; + } + } + } else { + looksLikeInt = (length && isdigit(UCHAR(*p))); + if (looksLikeInt) { + length--; + p++; + while (length && isdigit(UCHAR(*p))) { + length--; + p++; + } + } + } + while (length && isspace(UCHAR(*p))) { + length--; + p++; + } + looksLikeInt = !length; + } + if (looksLikeInt) { + /* + * If something that looks like an integer could not be + * converted, then it *must* be a bad octal or too large + * to represent [Bug 542588]. + */ - if (numBytes == 0) { - description = "empty string"; - } else if (TclCheckBadOctal(NULL, bytes)) { - description = "invalid octal number"; + if (TclCheckBadOctal(NULL, s)) { + msg = "invalid octal number"; + } else { + msg = "integer value too large to represent"; + Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", + "integer value too large to represent", (char *) NULL); + } } else { - description = "non-numeric string"; + /* + * See if the operand can be interpreted as a double in + * order to improve the error message. + */ + + double d; + + if (Tcl_GetDouble((Tcl_Interp *) NULL, s, &d) == TCL_OK) { + msg = "floating-point value"; + } } - } else if (type == TCL_NUMBER_NAN) { - description = "non-numeric floating-point value"; - } else if (type == TCL_NUMBER_DOUBLE) { - description = "floating-point value"; - } else { - /* TODO: No caller needs this. Eliminate? */ - description = "(big) integer"; + makeErrorMessage: + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "can't use ", + msg, " as operand of \"", operatorStrings[opCode - INST_LOR], + "\"", (char *) NULL); } - - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "can't use %s as operand of \"%s\"", description, operator)); - Tcl_SetErrorCode(interp, "ARITH", "DOMAIN", description, NULL); } /* *---------------------------------------------------------------------- * - * TclGetSrcInfoForPc, GetSrcInfoForPc, TclGetSrcInfoForCmd -- + * TclGetSrcInfoForPc, GetSrcInfoForPc -- * * Given a program counter value, finds the closest command in the * bytecode code unit's CmdLocation array and returns information about @@ -8076,101 +4816,85 @@ IllegalExprOperandType( * 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. + * 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: - * The CmdFrame at *cfPtr is updated. + * None. * *---------------------------------------------------------------------- */ -const char * -TclGetSrcInfoForCmd( - Interp *iPtr, - int *lenPtr) -{ - CmdFrame *cfPtr = iPtr->cmdFramePtr; - ByteCode *codePtr = (ByteCode *) cfPtr->data.tebc.codePtr; - - return GetSrcInfoForPc((unsigned char *) cfPtr->data.tebc.pc, - codePtr, lenPtr, NULL); -} - +#ifdef TCL_TIP280 void -TclGetSrcInfoForPc( - CmdFrame *cfPtr) +TclGetSrcInfoForPc (cfPtr) + CmdFrame* cfPtr; { - ByteCode *codePtr = (ByteCode *) cfPtr->data.tebc.codePtr; + ByteCode* codePtr = (ByteCode*) cfPtr->data.tebc.codePtr; if (cfPtr->cmd.str.cmd == NULL) { - cfPtr->cmd.str.cmd = GetSrcInfoForPc( - (unsigned char *) cfPtr->data.tebc.pc, codePtr, - &cfPtr->cmd.str.len, NULL); + cfPtr->cmd.str.cmd = GetSrcInfoForPc((unsigned char*) cfPtr->data.tebc.pc, + codePtr, + &cfPtr->cmd.str.len); } if (cfPtr->cmd.str.cmd != NULL) { - /* - * We now have the command. We can get the srcOffset back and from - * there find the list of word locations for this command. + /* We now have the command. We can get the srcOffset back and + * from there find the list of word locations for this command */ - ExtCmdLoc *eclPtr; - ECL *locPtr = NULL; - int srcOffset, i; - Interp *iPtr = (Interp *) *codePtr->interpHandle; - Tcl_HashEntry *hePtr = - Tcl_FindHashEntry(iPtr->lineBCPtr, codePtr); + ExtCmdLoc* eclPtr; + ECL* locPtr = NULL; + int srcOffset; - if (!hePtr) { - return; - } + Interp* iPtr = (Interp*) *codePtr->interpHandle; + Tcl_HashEntry* hePtr = Tcl_FindHashEntry (iPtr->lineBCPtr, (char *) codePtr); + + if (!hePtr) return; srcOffset = cfPtr->cmd.str.cmd - codePtr->source; - eclPtr = Tcl_GetHashValue(hePtr); + eclPtr = (ExtCmdLoc*) Tcl_GetHashValue (hePtr); - for (i=0; i < eclPtr->nuloc; i++) { - if (eclPtr->loc[i].srcOffset == srcOffset) { - locPtr = eclPtr->loc+i; - break; + { + int i; + for (i=0; i < eclPtr->nuloc; i++) { + if (eclPtr->loc [i].srcOffset == srcOffset) { + locPtr = &(eclPtr->loc [i]); + break; + } } } - if (locPtr == NULL) { - Tcl_Panic("LocSearch failure"); - } - cfPtr->line = locPtr->line; - cfPtr->nline = locPtr->nline; - cfPtr->type = eclPtr->type; + if (locPtr == NULL) {Tcl_Panic ("LocSearch failure");} + + cfPtr->line = locPtr->line; + cfPtr->nline = locPtr->nline; + cfPtr->type = eclPtr->type; if (eclPtr->type == TCL_LOCATION_SOURCE) { cfPtr->data.eval.path = eclPtr->path; - Tcl_IncrRefCount(cfPtr->data.eval.path); + Tcl_IncrRefCount (cfPtr->data.eval.path); } - - /* - * Do not set cfPtr->data.eval.path NULL for non-SOURCE. Needed for - * cfPtr->data.tebc.codePtr. + /* Do not set cfPtr->data.eval.path NULL for non-SOURCE + * Needed for cfPtr->data.tebc.codePtr. */ } } +#endif -static const char * -GetSrcInfoForPc( - const unsigned char *pc, /* The program counter value for which to +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 within a bytecode instruction + * 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. */ - const unsigned char **pcBeg)/* If non-NULL, the bytecode location - * where the current instruction starts. - * If NULL; no pointer is stored. */ + 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; @@ -8182,7 +4906,6 @@ GetSrcInfoForPc( int bestSrcLength = -1; /* Initialized to avoid compiler warning. */ if ((pcOffset < 0) || (pcOffset >= codePtr->numCodeBytes)) { - if (pcBeg != NULL) *pcBeg = NULL; return NULL; } @@ -8194,11 +4917,11 @@ GetSrcInfoForPc( codeDeltaNext = codePtr->codeDeltaStart; codeLengthNext = codePtr->codeLengthStart; - srcDeltaNext = codePtr->srcDeltaStart; + srcDeltaNext = codePtr->srcDeltaStart; srcLengthNext = codePtr->srcLengthStart; codeOffset = srcOffset = 0; for (i = 0; i < numCmds; i++) { - if ((unsigned) *codeDeltaNext == (unsigned) 0xFF) { + if ((unsigned int) (*codeDeltaNext) == (unsigned int) 0xFF) { codeDeltaNext++; delta = TclGetInt4AtPtr(codeDeltaNext); codeDeltaNext += 4; @@ -8208,7 +4931,7 @@ GetSrcInfoForPc( } codeOffset += delta; - if ((unsigned) *codeLengthNext == (unsigned) 0xFF) { + if ((unsigned int) (*codeLengthNext) == (unsigned int) 0xFF) { codeLengthNext++; codeLen = TclGetInt4AtPtr(codeLengthNext); codeLengthNext += 4; @@ -8218,7 +4941,7 @@ GetSrcInfoForPc( } codeEnd = (codeOffset + codeLen - 1); - if ((unsigned) *srcDeltaNext == (unsigned) 0xFF) { + if ((unsigned int) (*srcDeltaNext) == (unsigned int) 0xFF) { srcDeltaNext++; delta = TclGetInt4AtPtr(srcDeltaNext); srcDeltaNext += 4; @@ -8228,7 +4951,7 @@ GetSrcInfoForPc( } srcOffset += delta; - if ((unsigned) *srcLengthNext == (unsigned) 0xFF) { + if ((unsigned int) (*srcLengthNext) == (unsigned int) 0xFF) { srcLengthNext++; srcLen = TclGetInt4AtPtr(srcLengthNext); srcLengthNext += 4; @@ -8236,13 +4959,11 @@ GetSrcInfoForPc( srcLen = TclGetInt1AtPtr(srcLengthNext); srcLengthNext++; } - - if (codeOffset > pcOffset) { /* Best cmd already found */ + + if (codeOffset > pcOffset) { /* best cmd already found */ break; - } - if (pcOffset <= codeEnd) { /* This cmd's code encloses pc */ + } else if (pcOffset <= codeEnd) { /* this cmd's code encloses pc */ int dist = (pcOffset - codeOffset); - if (dist <= bestDist) { bestDist = dist; bestSrcOffset = srcOffset; @@ -8251,31 +4972,13 @@ GetSrcInfoForPc( } } - if (pcBeg != NULL) { - const unsigned char *curr, *prev; - - /* - * Walk from beginning of command or BC to pc, by complete - * instructions. Stop when crossing pc; keep previous. - */ - - curr = ((bestDist == INT_MAX) ? codePtr->codeStart : pc - bestDist); - prev = curr; - while (curr <= pc) { - prev = curr; - curr += tclInstructionTable[*curr].numBytes; - } - *pcBeg = prev; - } - if (bestDist == INT_MAX) { return NULL; } - + if (lengthPtr != NULL) { *lengthPtr = bestSrcLength; } - return (codePtr->source + bestSrcOffset); } @@ -8288,14 +4991,15 @@ GetSrcInfoForPc( * ExceptionRange. * * 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, 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. + * 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, 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. @@ -8304,32 +5008,33 @@ GetSrcInfoForPc( */ static ExceptionRange * -GetExceptRangeForPc( - const unsigned char *pc, /* The program counter value for which to +GetExceptRangeForPc(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 + int catchOnly; /* If 0, consider either loop or catch * ExceptionRanges in search. If nonzero - * consider only catch ranges (and ignore any - * closer loop ranges). */ - ByteCode *codePtr) /* Points to the ByteCode in which to search + * 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; int numRanges = codePtr->numExceptRanges; register ExceptionRange *rangePtr; - int pcOffset = pc - codePtr->codeStart; + int pcOffset = (pc - codePtr->codeStart); register int start; if (numRanges == 0) { return NULL; } - /* - * This exploits peculiarities of our compiler: nested ranges are always - * *after* their containing ranges, so that by scanning backwards we are - * sure that the first matching range is indeed the deepest. + /* + * This exploits peculiarities of our compiler: nested ranges + * are always *after* their containing ranges, so that by scanning + * backwards we are sure that the first matching range is indeed + * the deepest. */ rangeArrayPtr = codePtr->exceptArrayPtr; @@ -8337,7 +5042,7 @@ GetExceptRangeForPc( while (--rangePtr >= rangeArrayPtr) { start = rangePtr->codeOffset; if ((start <= pcOffset) && - (pcOffset < (start + rangePtr->numCodeBytes))) { + (pcOffset < (start + rangePtr->numCodeBytes))) { if ((!catchOnly) || (rangePtr->type == CATCH_EXCEPTION_RANGE)) { return rangePtr; @@ -8352,9 +5057,9 @@ GetExceptRangeForPc( * * GetOpcodeName -- * - * This procedure is called by the TRACE and TRACE_WITH_OBJ macros used - * in TclNRExecuteByteCode when debugging. It returns the name of the - * bytecode instruction at a specified instruction pc. + * This procedure is called by the TRACE and TRACE_WITH_OBJ macros + * used in TclExecuteByteCode when debugging. It returns the name of + * the bytecode instruction at a specified instruction pc. * * Results: * A character string for the instruction. @@ -8366,13 +5071,13 @@ GetExceptRangeForPc( */ #ifdef TCL_COMPILE_DEBUG -static const char * -GetOpcodeName( - const unsigned char *pc) /* Points to the instruction whose name should - * be returned. */ +static char * +GetOpcodeName(pc) + unsigned char *pc; /* Points to the instruction whose name + * should be returned. */ { unsigned char opCode = *pc; - + return tclInstructionTable[opCode].name; } #endif /* TCL_COMPILE_DEBUG */ @@ -8380,10 +5085,988 @@ GetOpcodeName( /* *---------------------------------------------------------------------- * + * VerifyExprObjType -- + * + * This procedure is called by the math functions to verify that + * the object is either an int or double, coercing it if necessary. + * If an error occurs during conversion, an error message is left + * in the interpreter's result unless "interp" is NULL. + * + * Results: + * TCL_OK if it was int or double, TCL_ERROR otherwise + * + * Side effects: + * objPtr is ensured to be of tclIntType, tclWideIntType or + * tclDoubleType. + * + *---------------------------------------------------------------------- + */ + +static int +VerifyExprObjType(interp, objPtr) + Tcl_Interp *interp; /* The interpreter in which to execute the + * function. */ + Tcl_Obj *objPtr; /* Points to the object to type check. */ +{ + if (IS_NUMERIC_TYPE(objPtr->typePtr)) { + return TCL_OK; + } else { + int length, result = TCL_OK; + char *s = Tcl_GetStringFromObj(objPtr, &length); + + if (TclLooksLikeInt(s, length)) { + long i; + Tcl_WideInt w; + GET_WIDE_OR_INT(result, objPtr, i, w); + } else { + double d; + result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL, objPtr, &d); + } + if ((result != TCL_OK) && (interp != NULL)) { + Tcl_ResetResult(interp); + if (TclCheckBadOctal((Tcl_Interp *) NULL, s)) { + Tcl_AppendToObj(Tcl_GetObjResult(interp), + "argument to math function was an invalid octal number", + -1); + } else { + Tcl_AppendToObj(Tcl_GetObjResult(interp), + "argument to math function didn't have numeric value", + -1); + } + } + return result; + } +} + +/* + *---------------------------------------------------------------------- + * + * 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. */ +{ + Tcl_Obj **stackPtr; /* Cached evaluation stack base pointer. */ + register int stackTop; /* Cached top index of evaluation stack. */ + register Tcl_Obj *valuePtr; + double d, dResult; + int result; + + double (*func) _ANSI_ARGS_((double)) = + (double (*)_ANSI_ARGS_((double))) clientData; + + /* + * Set stackPtr and stackTop from eePtr. + */ + + result = TCL_OK; + CACHE_STACK_INFO(); + + /* + * Pop the function's argument from the evaluation stack. Convert it + * to a double if necessary. + */ + + valuePtr = POP_OBJECT(); + + if (VerifyExprObjType(interp, valuePtr) != TCL_OK) { + result = TCL_ERROR; + goto done; + } + + GET_DOUBLE_VALUE(d, valuePtr, valuePtr->typePtr); + + 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: + TclDecrRefCount(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. */ +{ + Tcl_Obj **stackPtr; /* Cached evaluation stack base pointer. */ + register int stackTop; /* Cached top index of evaluation stack. */ + register Tcl_Obj *valuePtr, *value2Ptr; + double d1, d2, dResult; + int result; + + double (*func) _ANSI_ARGS_((double, double)) + = (double (*)_ANSI_ARGS_((double, double))) clientData; + + /* + * Set stackPtr and stackTop from eePtr. + */ + + result = TCL_OK; + 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(); + + if ((VerifyExprObjType(interp, valuePtr) != TCL_OK) || + (VerifyExprObjType(interp, value2Ptr) != TCL_OK)) { + result = TCL_ERROR; + goto done; + } + + GET_DOUBLE_VALUE(d1, valuePtr, valuePtr->typePtr); + GET_DOUBLE_VALUE(d2, value2Ptr, value2Ptr->typePtr); + + 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: + TclDecrRefCount(valuePtr); + TclDecrRefCount(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. */ +{ + Tcl_Obj **stackPtr; /* Cached evaluation stack base pointer. */ + register int stackTop; /* Cached top index of evaluation stack. */ + register Tcl_Obj *valuePtr; + long i, iResult; + double d, dResult; + int result; + + /* + * Set stackPtr and stackTop from eePtr. + */ + + result = TCL_OK; + CACHE_STACK_INFO(); + + /* + * Pop the argument from the evaluation stack. + */ + + valuePtr = POP_OBJECT(); + + if (VerifyExprObjType(interp, valuePtr) != TCL_OK) { + result = TCL_ERROR; + goto done; + } + + /* + * Push a Tcl object with the result. + */ + if (valuePtr->typePtr == &tclIntType) { + i = valuePtr->internalRep.longValue; + if (i < 0) { + if (i == LONG_MIN) { +#ifdef TCL_WIDE_INT_IS_LONG + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "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 + /* + * Special case: abs(MIN_INT) must promote to wide. + */ + + PUSH_OBJECT( Tcl_NewWideIntObj(-(Tcl_WideInt) i) ); + result = TCL_OK; + goto done; +#endif + + } + iResult = -i; + } else { + iResult = i; + } + PUSH_OBJECT(Tcl_NewLongObj(iResult)); + } else if (valuePtr->typePtr == &tclWideIntType) { + Tcl_WideInt wResult, w; + TclGetWide(w,valuePtr); + if (w < W0) { + wResult = -w; + if (wResult < 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 { + wResult = w; + } + PUSH_OBJECT(Tcl_NewWideIntObj(wResult)); + } else { + d = valuePtr->internalRep.doubleValue; + if (d < 0.0) { + dResult = -d; + } else if (d == -0.0) { + /* We need to distinguish here between positive 0.0 and + * negative -0.0, see Bug ID #2954959. + */ + static const double poszero = 0.0; + if (memcmp(&d, &poszero, sizeof(double))) { + dResult = -d; + } else { + 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: + TclDecrRefCount(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. */ +{ + Tcl_Obj **stackPtr; /* Cached evaluation stack base pointer. */ + register int stackTop; /* Cached top index of evaluation stack. */ + register Tcl_Obj *valuePtr; + double dResult; + int result; + + /* + * Set stackPtr and stackTop from eePtr. + */ + + result = TCL_OK; + CACHE_STACK_INFO(); + + /* + * Pop the argument from the evaluation stack. + */ + + valuePtr = POP_OBJECT(); + + if (VerifyExprObjType(interp, valuePtr) != TCL_OK) { + result = TCL_ERROR; + goto done; + } + + GET_DOUBLE_VALUE(dResult, valuePtr, valuePtr->typePtr); + + /* + * Push a Tcl object with the result. + */ + + PUSH_OBJECT(Tcl_NewDoubleObj(dResult)); + + /* + * Reflect the change to stackTop back in eePtr. + */ + + done: + TclDecrRefCount(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. */ +{ + Tcl_Obj **stackPtr; /* Cached evaluation stack base pointer. */ + register int stackTop; /* Cached top index of evaluation stack. */ + register Tcl_Obj *valuePtr; + long iResult; + double d; + int result; + + /* + * Set stackPtr and stackTop from eePtr. + */ + + result = TCL_OK; + CACHE_STACK_INFO(); + + /* + * Pop the argument from the evaluation stack. + */ + + valuePtr = POP_OBJECT(); + + if (VerifyExprObjType(interp, valuePtr) != TCL_OK) { + result = TCL_ERROR; + goto done; + } + + if (valuePtr->typePtr == &tclIntType) { + iResult = valuePtr->internalRep.longValue; + } else if (valuePtr->typePtr == &tclWideIntType) { + TclGetLongFromWide(iResult,valuePtr); + } else { + d = valuePtr->internalRep.doubleValue; + 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 a Tcl object with the result. + */ + + PUSH_OBJECT(Tcl_NewLongObj(iResult)); + + /* + * Reflect the change to stackTop back in eePtr. + */ + + done: + TclDecrRefCount(valuePtr); + DECACHE_STACK_INFO(); + return result; +} + +static int +ExprWideFunc(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. */ +{ + Tcl_Obj **stackPtr; /* Cached evaluation stack base pointer. */ + register int stackTop; /* Cached top index of evaluation stack. */ + register Tcl_Obj *valuePtr; + Tcl_WideInt wResult; + double d; + int result; + + /* + * Set stackPtr and stackTop from eePtr. + */ + + result = TCL_OK; + CACHE_STACK_INFO(); + + /* + * Pop the argument from the evaluation stack. + */ + + valuePtr = POP_OBJECT(); + + if (VerifyExprObjType(interp, valuePtr) != TCL_OK) { + result = TCL_ERROR; + goto done; + } + + if (valuePtr->typePtr == &tclWideIntType) { + TclGetWide(wResult,valuePtr); + } else if (valuePtr->typePtr == &tclIntType) { + wResult = Tcl_LongAsWide(valuePtr->internalRep.longValue); + } else { + d = valuePtr->internalRep.doubleValue; + if (d < 0.0) { + if (d < Tcl_WideAsDouble(LLONG_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 > Tcl_WideAsDouble(LLONG_MAX)) { + goto tooLarge; + } + } + if (IS_NAN(d) || IS_INF(d)) { + TclExprFloatError(interp, d); + result = TCL_ERROR; + goto done; + } + wResult = Tcl_DoubleAsWide(d); + } + + /* + * Push a Tcl object with the result. + */ + + PUSH_OBJECT(Tcl_NewWideIntObj(wResult)); + + /* + * Reflect the change to stackTop back in eePtr. + */ + + done: + TclDecrRefCount(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. */ +{ + Tcl_Obj **stackPtr; /* Cached evaluation stack base pointer. */ + register int stackTop; /* Cached top index of evaluation stack. */ + Interp *iPtr = (Interp *) interp; + double dResult; + long tmp; /* Algorithm assumes at least 32 bits. + * Only long guarantees that. See below. */ + + if (!(iPtr->flags & RAND_SEED_INITIALIZED)) { + iPtr->flags |= RAND_SEED_INITIALIZED; + + /* + * Take into consideration the thread this interp is running in order + * to insure different seeds in different threads (bug #416643) + */ + + iPtr->randSeed = TclpGetClicks() + ((long)Tcl_GetCurrentThread()<<12); + + /* + * Make sure 1 <= randSeed <= (2^31) - 2. See below. + */ + + iPtr->randSeed &= (unsigned long) 0x7fffffff; + if ((iPtr->randSeed == 0) || (iPtr->randSeed == 0x7fffffff)) { + iPtr->randSeed ^= 123459876; + } + } + + /* + * 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. The recurrence maps + * a seed in the range [1, IM - 1] to a new seed in that same range. + * The recurrence maps IM to 0, and maps 0 back to 0, so those two + * values must not be allowed as initial values of seed. + * + * In order to avoid potential problems with integer overflow, the + * recurrence is implemented in terms of additional constants + * IQ and IR such that + * IM = IA*IQ + IR + * None of the operations in the implementation overflows a 32-bit + * signed integer, and the C type long is guaranteed to be at least + * 32 bits wide. + * + * For more 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 + + 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; + } + + /* + * Since the recurrence keeps seed values in the range [1, RAND_IM - 1], + * dividing by RAND_IM yields a double in the range (0, 1). + */ + + 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. */ +{ + Tcl_Obj **stackPtr; /* Cached evaluation stack base pointer. */ + register int stackTop; /* Cached top index of evaluation stack. */ + Tcl_Obj *valuePtr, *resPtr; + double d, f, i; + int result; + + /* + * Set stackPtr and stackTop from eePtr. + */ + + result = TCL_OK; + CACHE_STACK_INFO(); + + /* + * Pop the argument from the evaluation stack. + */ + + valuePtr = POP_OBJECT(); + + if (VerifyExprObjType(interp, valuePtr) != TCL_OK) { + result = TCL_ERROR; + goto done; + } + + if ((valuePtr->typePtr == &tclIntType) || + (valuePtr->typePtr == &tclWideIntType)) { + result = TCL_OK; + resPtr = valuePtr; + } else { + + /* + * Round the number to the nearest integer. I'd like to use round(), + * but it's C99 (or BSD), and not yet universal. + */ + + d = valuePtr->internalRep.doubleValue; + f = modf(d, &i); + if (d < 0.0) { + if (f <= -0.5) { + i += -1.0; + } + if (i <= Tcl_WideAsDouble(LLONG_MIN)) { + goto tooLarge; + } else if (i <= (double) LONG_MIN) { + resPtr = Tcl_NewWideIntObj(Tcl_DoubleAsWide(i)); + } else { + resPtr = Tcl_NewLongObj((long) i); + } + } else { + if (f >= 0.5) { + i += 1.0; + } + if (i >= Tcl_WideAsDouble(LLONG_MAX)) { + goto tooLarge; + } else if (i >= (double) LONG_MAX) { + resPtr = Tcl_NewWideIntObj(Tcl_DoubleAsWide(i)); + } else { + resPtr = Tcl_NewLongObj((long) i); + } + } + } + + /* + * Push the result object and free the argument Tcl_Obj. + */ + + PUSH_OBJECT(resPtr); + + done: + TclDecrRefCount(valuePtr); + DECACHE_STACK_INFO(); + return result; + + /* + * Error return: result cannot be represented as an integer. + */ + + 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; +} + +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. */ +{ + Tcl_Obj **stackPtr; /* Cached evaluation stack base pointer. */ + register int stackTop; /* Cached top index of evaluation stack. */ + Interp *iPtr = (Interp *) interp; + Tcl_Obj *valuePtr; + long i = 0; /* Initialized to avoid compiler warning. */ + + /* + * 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(); + + if (VerifyExprObjType(interp, valuePtr) != TCL_OK) { + goto badValue; + } + + if (Tcl_GetLongFromObj(NULL, valuePtr, &i) != TCL_OK) { + Tcl_WideInt w; + + if (Tcl_GetWideIntFromObj(interp, valuePtr, &w) != TCL_OK) { + badValue: + Tcl_AddErrorInfo(interp, "\n (argument to \"srand()\")"); + TclDecrRefCount(valuePtr); + DECACHE_STACK_INFO(); + return TCL_ERROR; + } + + i = Tcl_WideAsLong(w); + } + + /* + * Reset the seed. Make sure 1 <= randSeed <= 2^31 - 2. + * See comments in ExprRandFunc() for more details. + */ + + iPtr->flags |= RAND_SEED_INITIALIZED; + iPtr->randSeed = i; + iPtr->randSeed &= (unsigned long) 0x7fffffff; + if ((iPtr->randSeed == 0) || (iPtr->randSeed == 0x7fffffff)) { + iPtr->randSeed ^= 123459876; + } + + /* + * 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. + */ + + TclDecrRefCount(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; + Tcl_Obj **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; + 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. + */ + + funcName = TclGetString(objv[0]); + 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]; + + if (VerifyExprObjType(interp, valuePtr) != TCL_OK) { + result = TCL_ERROR; + goto done; + } + + /* + * Copy the object's numeric value to the argument record, + * converting it if necessary. + */ + + if (valuePtr->typePtr == &tclIntType) { + i = valuePtr->internalRep.longValue; + if (mathFuncPtr->argTypes[k] == TCL_DOUBLE) { + args[k].type = TCL_DOUBLE; + args[k].doubleValue = i; + } else if (mathFuncPtr->argTypes[k] == TCL_WIDE_INT) { + args[k].type = TCL_WIDE_INT; + args[k].wideValue = Tcl_LongAsWide(i); + } else { + args[k].type = TCL_INT; + args[k].intValue = i; + } + } else if (valuePtr->typePtr == &tclWideIntType) { + Tcl_WideInt w; + TclGetWide(w,valuePtr); + if (mathFuncPtr->argTypes[k] == TCL_DOUBLE) { + args[k].type = TCL_DOUBLE; + args[k].doubleValue = Tcl_WideAsDouble(w); + } else if (mathFuncPtr->argTypes[k] == TCL_INT) { + args[k].type = TCL_INT; + args[k].intValue = Tcl_WideAsLong(w); + } else { + args[k].type = TCL_WIDE_INT; + args[k].wideValue = w; + } + } else { + d = valuePtr->internalRep.doubleValue; + if (mathFuncPtr->argTypes[k] == TCL_INT) { + args[k].type = TCL_INT; + args[k].intValue = (long) d; + } else if (mathFuncPtr->argTypes[k] == TCL_WIDE_INT) { + args[k].type = TCL_WIDE_INT; + args[k].wideValue = Tcl_DoubleAsWide(d); + } else { + args[k].type = TCL_DOUBLE; + args[k].doubleValue = d; + } + } + } + + /* + * Invoke the function and copy its result back into valuePtr. + */ + + result = (*mathFuncPtr->proc)(mathFuncPtr->clientData, interp, args, + &funcResult); + if (result != TCL_OK) { + goto done; + } + + /* + * Pop the objc top stack elements and decrement their ref counts. + */ + + k = (stackTop - (objc-1)); + while (stackTop >= k) { + valuePtr = POP_OBJECT(); + TclDecrRefCount(valuePtr); + } + + /* + * Push the call's object result. + */ + + if (funcResult.type == TCL_INT) { + PUSH_OBJECT(Tcl_NewLongObj(funcResult.intValue)); + } else if (funcResult.type == TCL_WIDE_INT) { + PUSH_OBJECT(Tcl_NewWideIntObj(funcResult.wideValue)); + } 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. + * 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. @@ -8395,34 +6078,34 @@ GetOpcodeName( */ void -TclExprFloatError( - Tcl_Interp *interp, /* Where to store error message. */ - double value) /* Value returned after error; used to +TclExprFloatError(interp, value) + Tcl_Interp *interp; /* Where to store error message. */ + double value; /* Value returned after error; used to * distinguish underflows from overflows. */ { - const char *s; + char *s; - if ((errno == EDOM) || TclIsNaN(value)) { + Tcl_ResetResult(interp); + if ((errno == EDOM) || IS_NAN(value)) { s = "domain error: argument not in valid range"; - Tcl_SetObjResult(interp, Tcl_NewStringObj(s, -1)); - Tcl_SetErrorCode(interp, "ARITH", "DOMAIN", s, NULL); - } else if ((errno == ERANGE) || TclIsInfinite(value)) { + 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_SetObjResult(interp, Tcl_NewStringObj(s, -1)); - Tcl_SetErrorCode(interp, "ARITH", "UNDERFLOW", s, NULL); + 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_SetObjResult(interp, Tcl_NewStringObj(s, -1)); - Tcl_SetErrorCode(interp, "ARITH", "OVERFLOW", s, NULL); + Tcl_AppendToObj(Tcl_GetObjResult(interp), s, -1); + Tcl_SetErrorCode(interp, "ARITH", "OVERFLOW", s, (char *) NULL); } } else { - Tcl_Obj *objPtr = Tcl_ObjPrintf( - "unknown floating-point error, errno = %d", errno); - - Tcl_SetErrorCode(interp, "ARITH", "UNKNOWN", - Tcl_GetString(objPtr), NULL); - Tcl_SetObjResult(interp, objPtr); + char msg[64 + TCL_INTEGER_SPACE]; + + sprintf(msg, "unknown floating-point error, errno = %d", errno); + Tcl_AppendToObj(Tcl_GetObjResult(interp), msg, -1); + Tcl_SetErrorCode(interp, "ARITH", "UNKNOWN", msg, (char *) NULL); } } @@ -8436,8 +6119,8 @@ TclExprFloatError( * 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. + * 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. @@ -8446,9 +6129,9 @@ TclExprFloatError( */ int -TclLog2( - register int value) /* The integer for which to compute the log - * base 2. */ +TclLog2(value) + register int value; /* The integer for which to compute the + * log base 2. */ { register int n = value; register int result = 0; @@ -8478,15 +6161,15 @@ TclLog2( */ static int -EvalStatsCmd( - ClientData unused, /* Unused. */ - Tcl_Interp *interp, /* The current interpreter. */ - int objc, /* The number of arguments. */ - Tcl_Obj *const objv[]) /* The argument strings. */ +EvalStatsCmd(unused, interp, objc, objv) + ClientData unused; /* Unused. */ + Tcl_Interp *interp; /* The current interpreter. */ + int objc; /* The number of arguments. */ + Tcl_Obj *CONST objv[]; /* The argument strings. */ { Interp *iPtr = (Interp *) interp; - LiteralTable *globalTablePtr = &iPtr->literalTable; - ByteCodeStats *statsPtr = &iPtr->stats; + LiteralTable *globalTablePtr = &(iPtr->literalTable); + ByteCodeStats *statsPtr = &(iPtr->stats); double totalCodeBytes, currentCodeBytes; double totalLiteralBytes, currentLiteralBytes; double objBytesIfUnshared, strBytesIfUnshared, sharingBytesSaved; @@ -8498,18 +6181,12 @@ EvalStatsCmd( int decadeHigh, minSizeDecade, maxSizeDecade, length, i; char *litTableStats; LiteralEntry *entryPtr; - Tcl_Obj *objPtr; - -#define Percent(a,b) ((a) * 100.0 / (b)) - - objPtr = Tcl_NewObj(); - Tcl_IncrRefCount(objPtr); numInstructions = 0.0; for (i = 0; i < 256; i++) { - if (statsPtr->instructionCount[i] != 0) { - numInstructions += statsPtr->instructionCount[i]; - } + if (statsPtr->instructionCount[i] != 0) { + numInstructions += statsPtr->instructionCount[i]; + } } totalLiteralBytes = sizeof(LiteralTable) @@ -8522,7 +6199,7 @@ EvalStatsCmd( numCurrentByteCodes = statsPtr->numCompilations - statsPtr->numByteCodesFreed; currentHeaderBytes = numCurrentByteCodes - * (sizeof(ByteCode) - sizeof(size_t) - sizeof(Tcl_Time)); + * (sizeof(ByteCode) - (sizeof(size_t) + sizeof(Tcl_Time))); literalMgmtBytes = sizeof(LiteralTable) + (iPtr->literalTable.numBuckets * sizeof(LiteralEntry *)) + (iPtr->literalTable.numEntries * sizeof(LiteralEntry)); @@ -8530,93 +6207,94 @@ EvalStatsCmd( + iPtr->literalTable.numEntries * sizeof(Tcl_Obj) + statsPtr->currentLitStringBytes; currentCodeBytes = statsPtr->currentByteCodeBytes + currentLiteralBytes; - + /* * Summary statistics, total and current source and ByteCode sizes. */ - Tcl_AppendPrintfToObj(objPtr, "\n----------------------------------------------------------------\n"); - Tcl_AppendPrintfToObj(objPtr, - "Compilation and execution statistics for interpreter %#lx\n", - (long int)iPtr); + fprintf(stdout, "\n----------------------------------------------------------------\n"); + fprintf(stdout, + "Compilation and execution statistics for interpreter 0x%x\n", + (unsigned int) iPtr); - Tcl_AppendPrintfToObj(objPtr, "\nNumber ByteCodes executed\t%ld\n", + fprintf(stdout, "\nNumber ByteCodes executed %ld\n", statsPtr->numExecutions); - Tcl_AppendPrintfToObj(objPtr, "Number ByteCodes compiled\t%ld\n", + fprintf(stdout, "Number ByteCodes compiled %ld\n", statsPtr->numCompilations); - Tcl_AppendPrintfToObj(objPtr, " Mean executions/compile\t%.1f\n", - statsPtr->numExecutions / (float)statsPtr->numCompilations); - - Tcl_AppendPrintfToObj(objPtr, "\nInstructions executed\t\t%.0f\n", + fprintf(stdout, " Mean executions/compile %.1f\n", + ((float)statsPtr->numExecutions) / ((float)statsPtr->numCompilations)); + + fprintf(stdout, "\nInstructions executed %.0f\n", numInstructions); - Tcl_AppendPrintfToObj(objPtr, " Mean inst/compile\t\t%.0f\n", + fprintf(stdout, " Mean inst/compile %.0f\n", numInstructions / statsPtr->numCompilations); - Tcl_AppendPrintfToObj(objPtr, " Mean inst/execution\t\t%.0f\n", + fprintf(stdout, " Mean inst/execution %.0f\n", numInstructions / statsPtr->numExecutions); - Tcl_AppendPrintfToObj(objPtr, "\nTotal ByteCodes\t\t\t%ld\n", + fprintf(stdout, "\nTotal ByteCodes %ld\n", statsPtr->numCompilations); - Tcl_AppendPrintfToObj(objPtr, " Source bytes\t\t\t%.6g\n", + fprintf(stdout, " Source bytes %.6g\n", statsPtr->totalSrcBytes); - Tcl_AppendPrintfToObj(objPtr, " Code bytes\t\t\t%.6g\n", + fprintf(stdout, " Code bytes %.6g\n", totalCodeBytes); - Tcl_AppendPrintfToObj(objPtr, " ByteCode bytes\t\t%.6g\n", + fprintf(stdout, " ByteCode bytes %.6g\n", statsPtr->totalByteCodeBytes); - Tcl_AppendPrintfToObj(objPtr, " Literal bytes\t\t%.6g\n", + fprintf(stdout, " Literal bytes %.6g\n", totalLiteralBytes); - Tcl_AppendPrintfToObj(objPtr, " table %lu + bkts %lu + entries %lu + objects %lu + strings %.6g\n", - (unsigned long) sizeof(LiteralTable), - (unsigned long) (iPtr->literalTable.numBuckets * sizeof(LiteralEntry *)), - (unsigned long) (statsPtr->numLiteralsCreated * sizeof(LiteralEntry)), - (unsigned long) (statsPtr->numLiteralsCreated * sizeof(Tcl_Obj)), + fprintf(stdout, " table %u + bkts %lu + entries %lu + objects %lu + strings %.6g\n", + (unsigned int)sizeof(LiteralTable), + (unsigned long)iPtr->literalTable.numBuckets * sizeof(LiteralEntry *), + (unsigned long)statsPtr->numLiteralsCreated * sizeof(LiteralEntry), + (unsigned long)statsPtr->numLiteralsCreated * sizeof(Tcl_Obj), statsPtr->totalLitStringBytes); - Tcl_AppendPrintfToObj(objPtr, " Mean code/compile\t\t%.1f\n", + fprintf(stdout, " Mean code/compile %.1f\n", totalCodeBytes / statsPtr->numCompilations); - Tcl_AppendPrintfToObj(objPtr, " Mean code/source\t\t%.1f\n", + fprintf(stdout, " Mean code/source %.1f\n", totalCodeBytes / statsPtr->totalSrcBytes); - Tcl_AppendPrintfToObj(objPtr, "\nCurrent (active) ByteCodes\t%ld\n", + fprintf(stdout, "\nCurrent (active) ByteCodes %ld\n", numCurrentByteCodes); - Tcl_AppendPrintfToObj(objPtr, " Source bytes\t\t\t%.6g\n", + fprintf(stdout, " Source bytes %.6g\n", statsPtr->currentSrcBytes); - Tcl_AppendPrintfToObj(objPtr, " Code bytes\t\t\t%.6g\n", + fprintf(stdout, " Code bytes %.6g\n", currentCodeBytes); - Tcl_AppendPrintfToObj(objPtr, " ByteCode bytes\t\t%.6g\n", + fprintf(stdout, " ByteCode bytes %.6g\n", statsPtr->currentByteCodeBytes); - Tcl_AppendPrintfToObj(objPtr, " Literal bytes\t\t%.6g\n", + fprintf(stdout, " Literal bytes %.6g\n", currentLiteralBytes); - Tcl_AppendPrintfToObj(objPtr, " table %lu + bkts %lu + entries %lu + objects %lu + strings %.6g\n", - (unsigned long) sizeof(LiteralTable), - (unsigned long) (iPtr->literalTable.numBuckets * sizeof(LiteralEntry *)), - (unsigned long) (iPtr->literalTable.numEntries * sizeof(LiteralEntry)), - (unsigned long) (iPtr->literalTable.numEntries * sizeof(Tcl_Obj)), + fprintf(stdout, " table %u + bkts %lu + entries %lu + objects %lu + strings %.6g\n", + (unsigned int)sizeof(LiteralTable), + (unsigned long)iPtr->literalTable.numBuckets * sizeof(LiteralEntry *), + (unsigned long)iPtr->literalTable.numEntries * sizeof(LiteralEntry), + (unsigned long)iPtr->literalTable.numEntries * sizeof(Tcl_Obj), statsPtr->currentLitStringBytes); - Tcl_AppendPrintfToObj(objPtr, " Mean code/source\t\t%.1f\n", + fprintf(stdout, " Mean code/source %.1f\n", currentCodeBytes / statsPtr->currentSrcBytes); - Tcl_AppendPrintfToObj(objPtr, " Code + source bytes\t\t%.6g (%0.1f mean code/src)\n", + fprintf(stdout, " Code + source bytes %.6g (%0.1f mean code/src)\n", (currentCodeBytes + statsPtr->currentSrcBytes), (currentCodeBytes / statsPtr->currentSrcBytes) + 1.0); /* * Tcl_IsShared statistics check * - * This gives the refcount of each obj as Tcl_IsShared was called for it. - * Shared objects must be duplicated before they can be modified. + * This gives the refcount of each obj as Tcl_IsShared was called + * for it. Shared objects must be duplicated before they can be + * modified. */ numSharedMultX = 0; - Tcl_AppendPrintfToObj(objPtr, "\nTcl_IsShared object check (all objects):\n"); - Tcl_AppendPrintfToObj(objPtr, " Object had refcount <=1 (not shared)\t%ld\n", + fprintf(stdout, "\nTcl_IsShared object check (all objects):\n"); + fprintf(stdout, " Object had refcount <=1 (not shared) %ld\n", tclObjsShared[1]); for (i = 2; i < TCL_MAX_SHARED_OBJ_STATS; i++) { - Tcl_AppendPrintfToObj(objPtr, " refcount ==%d\t\t%ld\n", + fprintf(stdout, " refcount ==%d %ld\n", i, tclObjsShared[i]); numSharedMultX += tclObjsShared[i]; } - Tcl_AppendPrintfToObj(objPtr, " refcount >=%d\t\t%ld\n", + fprintf(stdout, " refcount >=%d %ld\n", i, tclObjsShared[0]); numSharedMultX += tclObjsShared[0]; - Tcl_AppendPrintfToObj(objPtr, " Total shared objects\t\t\t%d\n", + fprintf(stdout, " Total shared objects %d\n", numSharedMultX); /* @@ -8626,14 +6304,14 @@ EvalStatsCmd( numByteCodeLits = 0; refCountSum = 0; numSharedMultX = 0; - numSharedOnce = 0; - objBytesIfUnshared = 0.0; - strBytesIfUnshared = 0.0; + numSharedOnce = 0; + objBytesIfUnshared = 0.0; + strBytesIfUnshared = 0.0; strBytesSharedMultX = 0.0; - strBytesSharedOnce = 0.0; + strBytesSharedOnce = 0.0; for (i = 0; i < globalTablePtr->numBuckets; i++) { for (entryPtr = globalTablePtr->buckets[i]; entryPtr != NULL; - entryPtr = entryPtr->nextPtr) { + entryPtr = entryPtr->nextPtr) { if (entryPtr->objPtr->typePtr == &tclByteCodeType) { numByteCodeLits++; } @@ -8653,230 +6331,213 @@ EvalStatsCmd( sharingBytesSaved = (objBytesIfUnshared + strBytesIfUnshared) - currentLiteralBytes; - Tcl_AppendPrintfToObj(objPtr, "\nTotal objects (all interps)\t%ld\n", + fprintf(stdout, "\nTotal objects (all interps) %ld\n", tclObjsAlloced); - Tcl_AppendPrintfToObj(objPtr, "Current objects\t\t\t%ld\n", + fprintf(stdout, "Current objects %ld\n", (tclObjsAlloced - tclObjsFreed)); - Tcl_AppendPrintfToObj(objPtr, "Total literal objects\t\t%ld\n", + fprintf(stdout, "Total literal objects %ld\n", statsPtr->numLiteralsCreated); - Tcl_AppendPrintfToObj(objPtr, "\nCurrent literal objects\t\t%d (%0.1f%% of current objects)\n", + fprintf(stdout, "\nCurrent literal objects %d (%0.1f%% of current objects)\n", globalTablePtr->numEntries, - Percent(globalTablePtr->numEntries, tclObjsAlloced-tclObjsFreed)); - Tcl_AppendPrintfToObj(objPtr, " ByteCode literals\t\t%ld (%0.1f%% of current literals)\n", + (globalTablePtr->numEntries * 100.0) / (tclObjsAlloced-tclObjsFreed)); + fprintf(stdout, " ByteCode literals %ld (%0.1f%% of current literals)\n", numByteCodeLits, - Percent(numByteCodeLits, globalTablePtr->numEntries)); - Tcl_AppendPrintfToObj(objPtr, " Literals reused > 1x\t\t%d\n", + (numByteCodeLits * 100.0) / globalTablePtr->numEntries); + fprintf(stdout, " Literals reused > 1x %d\n", numSharedMultX); - Tcl_AppendPrintfToObj(objPtr, " Mean reference count\t\t%.2f\n", + fprintf(stdout, " Mean reference count %.2f\n", ((double) refCountSum) / globalTablePtr->numEntries); - Tcl_AppendPrintfToObj(objPtr, " Mean len, str reused >1x \t%.2f\n", - (numSharedMultX ? strBytesSharedMultX/numSharedMultX : 0.0)); - Tcl_AppendPrintfToObj(objPtr, " Mean len, str used 1x\t\t%.2f\n", - (numSharedOnce ? strBytesSharedOnce/numSharedOnce : 0.0)); - Tcl_AppendPrintfToObj(objPtr, " Total sharing savings\t\t%.6g (%0.1f%% of bytes if no sharing)\n", + fprintf(stdout, " Mean len, str reused >1x %.2f\n", + (numSharedMultX? (strBytesSharedMultX/numSharedMultX) : 0.0)); + fprintf(stdout, " Mean len, str used 1x %.2f\n", + (numSharedOnce? (strBytesSharedOnce/numSharedOnce) : 0.0)); + fprintf(stdout, " Total sharing savings %.6g (%0.1f%% of bytes if no sharing)\n", sharingBytesSaved, - Percent(sharingBytesSaved, objBytesIfUnshared+strBytesIfUnshared)); - Tcl_AppendPrintfToObj(objPtr, " Bytes with sharing\t\t%.6g\n", + (sharingBytesSaved * 100.0) / (objBytesIfUnshared + strBytesIfUnshared)); + fprintf(stdout, " Bytes with sharing %.6g\n", currentLiteralBytes); - Tcl_AppendPrintfToObj(objPtr, " table %lu + bkts %lu + entries %lu + objects %lu + strings %.6g\n", - (unsigned long) sizeof(LiteralTable), - (unsigned long) (iPtr->literalTable.numBuckets * sizeof(LiteralEntry *)), - (unsigned long) (iPtr->literalTable.numEntries * sizeof(LiteralEntry)), - (unsigned long) (iPtr->literalTable.numEntries * sizeof(Tcl_Obj)), + fprintf(stdout, " table %u + bkts %lu + entries %lu + objects %lu + strings %.6g\n", + (unsigned int)sizeof(LiteralTable), + (unsigned long)iPtr->literalTable.numBuckets * sizeof(LiteralEntry *), + (unsigned long)iPtr->literalTable.numEntries * sizeof(LiteralEntry), + (unsigned long)iPtr->literalTable.numEntries * sizeof(Tcl_Obj), statsPtr->currentLitStringBytes); - Tcl_AppendPrintfToObj(objPtr, " Bytes if no sharing\t\t%.6g = objects %.6g + strings %.6g\n", + fprintf(stdout, " Bytes if no sharing %.6g = objects %.6g + strings %.6g\n", (objBytesIfUnshared + strBytesIfUnshared), objBytesIfUnshared, strBytesIfUnshared); - Tcl_AppendPrintfToObj(objPtr, " String sharing savings \t%.6g = unshared %.6g - shared %.6g\n", + fprintf(stdout, " String sharing savings %.6g = unshared %.6g - shared %.6g\n", (strBytesIfUnshared - statsPtr->currentLitStringBytes), strBytesIfUnshared, statsPtr->currentLitStringBytes); - Tcl_AppendPrintfToObj(objPtr, " Literal mgmt overhead\t\t%ld (%0.1f%% of bytes with sharing)\n", + fprintf(stdout, " Literal mgmt overhead %ld (%0.1f%% of bytes with sharing)\n", literalMgmtBytes, - Percent(literalMgmtBytes, currentLiteralBytes)); - Tcl_AppendPrintfToObj(objPtr, " table %lu + buckets %lu + entries %lu\n", - (unsigned long) sizeof(LiteralTable), - (unsigned long) (iPtr->literalTable.numBuckets * sizeof(LiteralEntry *)), - (unsigned long) (iPtr->literalTable.numEntries * sizeof(LiteralEntry))); + (literalMgmtBytes * 100.0) / currentLiteralBytes); + fprintf(stdout, " table %u + buckets %lu + entries %lu\n", + (unsigned int)sizeof(LiteralTable), + (unsigned long)iPtr->literalTable.numBuckets * sizeof(LiteralEntry *), + (unsigned long)iPtr->literalTable.numEntries * sizeof(LiteralEntry)); /* * Breakdown of current ByteCode space requirements. */ - - Tcl_AppendPrintfToObj(objPtr, "\nBreakdown of current ByteCode requirements:\n"); - Tcl_AppendPrintfToObj(objPtr, " Bytes Pct of Avg per\n"); - Tcl_AppendPrintfToObj(objPtr, " total ByteCode\n"); - Tcl_AppendPrintfToObj(objPtr, "Total %12.6g 100.00%% %8.1f\n", + + fprintf(stdout, "\nBreakdown of current ByteCode requirements:\n"); + fprintf(stdout, " Bytes Pct of Avg per\n"); + fprintf(stdout, " total ByteCode\n"); + fprintf(stdout, "Total %12.6g 100.00%% %8.1f\n", statsPtr->currentByteCodeBytes, statsPtr->currentByteCodeBytes / numCurrentByteCodes); - Tcl_AppendPrintfToObj(objPtr, "Header %12.6g %8.1f%% %8.1f\n", + fprintf(stdout, "Header %12.6g %8.1f%% %8.1f\n", currentHeaderBytes, - Percent(currentHeaderBytes, statsPtr->currentByteCodeBytes), + ((currentHeaderBytes * 100.0) / statsPtr->currentByteCodeBytes), currentHeaderBytes / numCurrentByteCodes); - Tcl_AppendPrintfToObj(objPtr, "Instructions %12.6g %8.1f%% %8.1f\n", + fprintf(stdout, "Instructions %12.6g %8.1f%% %8.1f\n", statsPtr->currentInstBytes, - Percent(statsPtr->currentInstBytes,statsPtr->currentByteCodeBytes), + ((statsPtr->currentInstBytes * 100.0) / statsPtr->currentByteCodeBytes), statsPtr->currentInstBytes / numCurrentByteCodes); - Tcl_AppendPrintfToObj(objPtr, "Literal ptr array %12.6g %8.1f%% %8.1f\n", + fprintf(stdout, "Literal ptr array %12.6g %8.1f%% %8.1f\n", statsPtr->currentLitBytes, - Percent(statsPtr->currentLitBytes,statsPtr->currentByteCodeBytes), + ((statsPtr->currentLitBytes * 100.0) / statsPtr->currentByteCodeBytes), statsPtr->currentLitBytes / numCurrentByteCodes); - Tcl_AppendPrintfToObj(objPtr, "Exception table %12.6g %8.1f%% %8.1f\n", + fprintf(stdout, "Exception table %12.6g %8.1f%% %8.1f\n", statsPtr->currentExceptBytes, - Percent(statsPtr->currentExceptBytes,statsPtr->currentByteCodeBytes), + ((statsPtr->currentExceptBytes * 100.0) / statsPtr->currentByteCodeBytes), statsPtr->currentExceptBytes / numCurrentByteCodes); - Tcl_AppendPrintfToObj(objPtr, "Auxiliary data %12.6g %8.1f%% %8.1f\n", + fprintf(stdout, "Auxiliary data %12.6g %8.1f%% %8.1f\n", statsPtr->currentAuxBytes, - Percent(statsPtr->currentAuxBytes,statsPtr->currentByteCodeBytes), + ((statsPtr->currentAuxBytes * 100.0) / statsPtr->currentByteCodeBytes), statsPtr->currentAuxBytes / numCurrentByteCodes); - Tcl_AppendPrintfToObj(objPtr, "Command map %12.6g %8.1f%% %8.1f\n", + fprintf(stdout, "Command map %12.6g %8.1f%% %8.1f\n", statsPtr->currentCmdMapBytes, - Percent(statsPtr->currentCmdMapBytes,statsPtr->currentByteCodeBytes), + ((statsPtr->currentCmdMapBytes * 100.0) / statsPtr->currentByteCodeBytes), statsPtr->currentCmdMapBytes / numCurrentByteCodes); /* * Detailed literal statistics. */ - - Tcl_AppendPrintfToObj(objPtr, "\nLiteral string sizes:\n"); - Tcl_AppendPrintfToObj(objPtr, "\t Up to length\t\tPercentage\n"); + + fprintf(stdout, "\nLiteral string sizes:\n"); + fprintf(stdout, " Up to length Percentage\n"); maxSizeDecade = 0; for (i = 31; i >= 0; i--) { - if (statsPtr->literalCount[i] > 0) { - maxSizeDecade = i; + if (statsPtr->literalCount[i] > 0) { + maxSizeDecade = i; break; - } + } } sum = 0; for (i = 0; i <= maxSizeDecade; i++) { decadeHigh = (1 << (i+1)) - 1; sum += statsPtr->literalCount[i]; - Tcl_AppendPrintfToObj(objPtr, "\t%10d\t\t%8.0f%%\n", - decadeHigh, Percent(sum, statsPtr->numLiteralsCreated)); + fprintf(stdout, " %10d %8.0f%%\n", + decadeHigh, (sum * 100.0) / statsPtr->numLiteralsCreated); } litTableStats = TclLiteralStats(globalTablePtr); - Tcl_AppendPrintfToObj(objPtr, "\nCurrent literal table statistics:\n%s\n", - litTableStats); - ckfree(litTableStats); + fprintf(stdout, "\nCurrent literal table statistics:\n%s\n", + litTableStats); + ckfree((char *) litTableStats); /* * Source and ByteCode size distributions. */ - Tcl_AppendPrintfToObj(objPtr, "\nSource sizes:\n"); - Tcl_AppendPrintfToObj(objPtr, "\t Up to size\t\tPercentage\n"); + fprintf(stdout, "\nSource sizes:\n"); + fprintf(stdout, " Up to size Percentage\n"); minSizeDecade = maxSizeDecade = 0; for (i = 0; i < 31; i++) { - if (statsPtr->srcCount[i] > 0) { + if (statsPtr->srcCount[i] > 0) { minSizeDecade = i; break; - } + } } for (i = 31; i >= 0; i--) { - if (statsPtr->srcCount[i] > 0) { - maxSizeDecade = i; + if (statsPtr->srcCount[i] > 0) { + maxSizeDecade = i; break; - } + } } sum = 0; for (i = minSizeDecade; i <= maxSizeDecade; i++) { decadeHigh = (1 << (i+1)) - 1; sum += statsPtr->srcCount[i]; - Tcl_AppendPrintfToObj(objPtr, "\t%10d\t\t%8.0f%%\n", - decadeHigh, Percent(sum, statsPtr->numCompilations)); + fprintf(stdout, " %10d %8.0f%%\n", + decadeHigh, (sum * 100.0) / statsPtr->numCompilations); } - Tcl_AppendPrintfToObj(objPtr, "\nByteCode sizes:\n"); - Tcl_AppendPrintfToObj(objPtr, "\t Up to size\t\tPercentage\n"); + fprintf(stdout, "\nByteCode sizes:\n"); + fprintf(stdout, " Up to size Percentage\n"); minSizeDecade = maxSizeDecade = 0; for (i = 0; i < 31; i++) { - if (statsPtr->byteCodeCount[i] > 0) { + if (statsPtr->byteCodeCount[i] > 0) { minSizeDecade = i; break; - } + } } for (i = 31; i >= 0; i--) { - if (statsPtr->byteCodeCount[i] > 0) { - maxSizeDecade = i; + if (statsPtr->byteCodeCount[i] > 0) { + maxSizeDecade = i; break; - } + } } sum = 0; for (i = minSizeDecade; i <= maxSizeDecade; i++) { decadeHigh = (1 << (i+1)) - 1; sum += statsPtr->byteCodeCount[i]; - Tcl_AppendPrintfToObj(objPtr, "\t%10d\t\t%8.0f%%\n", - decadeHigh, Percent(sum, statsPtr->numCompilations)); + fprintf(stdout, " %10d %8.0f%%\n", + decadeHigh, (sum * 100.0) / statsPtr->numCompilations); } - Tcl_AppendPrintfToObj(objPtr, "\nByteCode longevity (excludes Current ByteCodes):\n"); - Tcl_AppendPrintfToObj(objPtr, "\t Up to ms\t\tPercentage\n"); + fprintf(stdout, "\nByteCode longevity (excludes Current ByteCodes):\n"); + fprintf(stdout, " Up to ms Percentage\n"); minSizeDecade = maxSizeDecade = 0; for (i = 0; i < 31; i++) { - if (statsPtr->lifetimeCount[i] > 0) { + if (statsPtr->lifetimeCount[i] > 0) { minSizeDecade = i; break; - } + } } for (i = 31; i >= 0; i--) { - if (statsPtr->lifetimeCount[i] > 0) { - maxSizeDecade = i; + if (statsPtr->lifetimeCount[i] > 0) { + maxSizeDecade = i; break; - } + } } sum = 0; for (i = minSizeDecade; i <= maxSizeDecade; i++) { decadeHigh = (1 << (i+1)) - 1; sum += statsPtr->lifetimeCount[i]; - Tcl_AppendPrintfToObj(objPtr, "\t%12.3f\t\t%8.0f%%\n", - decadeHigh/1000.0, Percent(sum, statsPtr->numByteCodesFreed)); + fprintf(stdout, " %12.3f %8.0f%%\n", + decadeHigh / 1000.0, + (sum * 100.0) / statsPtr->numByteCodesFreed); } /* * Instruction counts. */ - Tcl_AppendPrintfToObj(objPtr, "\nInstruction counts:\n"); + fprintf(stdout, "\nInstruction counts:\n"); for (i = 0; i <= LAST_INST_OPCODE; i++) { - Tcl_AppendPrintfToObj(objPtr, "%20s %8ld ", - tclInstructionTable[i].name, statsPtr->instructionCount[i]); - if (statsPtr->instructionCount[i]) { - Tcl_AppendPrintfToObj(objPtr, "%6.1f%%\n", - Percent(statsPtr->instructionCount[i], numInstructions)); - } else { - Tcl_AppendPrintfToObj(objPtr, "0\n"); - } + if (statsPtr->instructionCount[i]) { + fprintf(stdout, "%20s %8ld %6.1f%%\n", + tclInstructionTable[i].name, + statsPtr->instructionCount[i], + (statsPtr->instructionCount[i]*100.0) / numInstructions); + } + } + + fprintf(stdout, "\nInstructions NEVER executed:\n"); + for (i = 0; i <= LAST_INST_OPCODE; i++) { + if (statsPtr->instructionCount[i] == 0) { + fprintf(stdout, "%20s\n", tclInstructionTable[i].name); + } } #ifdef TCL_MEM_DEBUG - Tcl_AppendPrintfToObj(objPtr, "\nHeap Statistics:\n"); - TclDumpMemoryInfo((ClientData) objPtr, 1); + fprintf(stdout, "\nHeap Statistics:\n"); + TclDumpMemoryInfo(stdout); #endif - Tcl_AppendPrintfToObj(objPtr, "\n----------------------------------------------------------------\n"); - - if (objc == 1) { - Tcl_SetObjResult(interp, objPtr); - } else { - Tcl_Channel outChan; - char *str = Tcl_GetStringFromObj(objv[1], &length); - - if (length) { - if (strcmp(str, "stdout") == 0) { - outChan = Tcl_GetStdChannel(TCL_STDOUT); - } else if (strcmp(str, "stderr") == 0) { - outChan = Tcl_GetStdChannel(TCL_STDERR); - } else { - outChan = Tcl_OpenFileChannel(NULL, str, "w", 0664); - } - } else { - outChan = Tcl_GetStdChannel(TCL_STDOUT); - } - if (outChan != NULL) { - Tcl_WriteObj(outChan, objPtr); - } - } - Tcl_DecrRefCount(objPtr); + fprintf(stdout, "\n----------------------------------------------------------------\n"); return TCL_OK; } #endif /* TCL_COMPILE_STATS */ @@ -8887,15 +6548,15 @@ EvalStatsCmd( * * StringForResultCode -- * - * Procedure that returns a human-readable string representing a Tcl - * result code such as TCL_ERROR. + * 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. + * 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. @@ -8903,13 +6564,13 @@ EvalStatsCmd( *---------------------------------------------------------------------- */ -static const char * -StringForResultCode( - int result) /* The Tcl result code for which to generate a - * string. */ +static CONST char * +StringForResultCode(result) + int result; /* The Tcl result code for which to + * generate a string. */ { static char buf[TCL_INTEGER_SPACE]; - + if ((result >= TCL_OK) && (result <= TCL_CONTINUE)) { return resultStrings[result]; } @@ -8925,3 +6586,4 @@ StringForResultCode( * fill-column: 78 * End: */ + |