diff options
Diffstat (limited to 'generic/tclExecute.c')
| -rw-r--r-- | generic/tclExecute.c | 9997 |
1 files changed, 4142 insertions, 5855 deletions
diff --git a/generic/tclExecute.c b/generic/tclExecute.c index de57fc5..bfb9d17 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -3,13 +3,12 @@ * * This file contains procedures that execute byte-compiled Tcl commands. * - * Copyright © 1996-1997 Sun Microsystems, Inc. - * Copyright © 1998-2000 Scriptics Corporation. - * Copyright © 2001 Kevin B. Kenny. All rights reserved. - * Copyright © 2002-2010 Miguel Sofer. - * Copyright © 2005-2007 Donal K. Fellows. - * Copyright © 2007 Daniel A. Steffen <das@users.sourceforge.net> - * Copyright © 2006-2008 Joe Mistachkin. All rights reserved. + * 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-2005 by Miguel Sofer. + * Copyright (c) 2005-2007 by Donal K. Fellows. + * Copyright (c) 2007 Daniel A. Steffen <das@users.sourceforge.net> * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. @@ -17,10 +16,10 @@ #include "tclInt.h" #include "tclCompile.h" -#include "tclOOInt.h" -#include "tclTomMath.h" +#include "tommath.h" + #include <math.h> -#include <assert.h> +#include <float.h> /* * Hack to determine whether we may expect IEEE floating point. The hack is @@ -34,14 +33,14 @@ #endif /* - * A counter that is used to work out when the bytecode engine should call - * Tcl_AsyncReady() to see whether there is a signal that needs handling, and - * other expensive periodic operations. + * 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. */ -#ifndef ASYNC_CHECK_COUNT -# define ASYNC_CHECK_COUNT 64 -#endif /* !ASYNC_CHECK_COUNT */ +#ifndef ASYNC_CHECK_COUNT_MASK +# define ASYNC_CHECK_COUNT_MASK 63 +#endif /* !ASYNC_CHECK_COUNT_MASK */ /* * Boolean flag indicating whether the Tcl bytecode interpreter has been @@ -51,8 +50,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,7 +70,7 @@ int tclTraceExec = 0; * 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-compatibility reasons. + * disjoint for backward-compatability reasons. */ static const char *const operatorStrings[] = { @@ -97,9 +94,9 @@ static const char *const resultStrings[] = { */ #ifdef TCL_COMPILE_STATS -size_t tclObjsAlloced = 0; -size_t tclObjsFreed = 0; -size_t tclObjsShared[TCL_MAX_SHARED_OBJ_STATS] = { 0, 0, 0, 0, 0 }; +long tclObjsAlloced = 0; +long tclObjsFreed = 0; +long tclObjsShared[TCL_MAX_SHARED_OBJ_STATS] = { 0, 0, 0, 0, 0 }; #endif /* TCL_COMPILE_STATS */ /* @@ -118,7 +115,7 @@ size_t tclObjsShared[TCL_MAX_SHARED_OBJ_STATS] = { 0, 0, 0, 0, 0 }; typedef struct { const char *name; /* Name of function. */ - int numArgs; /* Number of arguments for function. */ + int numArgs; /* Number of arguments for function. */ } BuiltinFunc; /* @@ -127,7 +124,7 @@ typedef struct { * operand byte. */ -static BuiltinFunc const tclBuiltinFuncTable[] = { +static const BuiltinFunc tclBuiltinFuncTable[] = { {"acos", 1}, {"asin", 1}, {"atan", 1}, @@ -159,58 +156,13 @@ static BuiltinFunc const tclBuiltinFuncTable[] = { #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 { - ByteCode *codePtr; /* Constant until the BC returns */ - /* -----------------------------------------*/ - Tcl_Obj **catchTop; /* These fields are used on return TO this */ - Tcl_Obj *auxObjList; /* level: they record the state when a new */ - CmdFrame cmdFrame; /* codePtr was received for NR execution. */ - Tcl_Obj *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; \ - TclNRAddCallback(interp, TEBCresume, \ - TD, pc, INT2PTR(cleanup), NULL); \ - } while (0) - -#define TEBC_DATA_DIG() \ - do { \ - tosPtr = esPtr->tosPtr; \ - } while (0) - -#define PUSH_TAUX_OBJ(objPtr) \ - do { \ - if (auxObjList) { \ - (objPtr)->length += auxObjList->length; \ - } \ - (objPtr)->internalRep.twoPtrValue.ptr1 = auxObjList; \ - auxObjList = (objPtr); \ - } while (0) - -#define POP_TAUX_OBJ() \ - do { \ - tmpPtr = auxObjList; \ - auxObjList = (Tcl_Obj *)tmpPtr->internalRep.twoPtrValue.ptr1; \ - Tcl_DecrRefCount(tmpPtr); \ - } while (0) - /* * These variable-access macros have to coincide with those in tclVar.c */ #define VarHashGetValue(hPtr) \ - ((Var *) ((char *)hPtr - offsetof(VarInHash, entry))) + ((Var *) ((char *)hPtr - TclOffset(VarInHash, entry))) static inline Var * VarHashCreateVar( @@ -218,8 +170,8 @@ VarHashCreateVar( Tcl_Obj *key, int *newPtr) { - Tcl_HashEntry *hPtr = Tcl_CreateHashEntry(&tablePtr->table, - key, newPtr); + Tcl_HashEntry *hPtr = Tcl_CreateHashEntry((Tcl_HashTable *) tablePtr, + (char *) key, newPtr); if (!hPtr) { return NULL; @@ -229,7 +181,7 @@ VarHashCreateVar( #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; @@ -242,153 +194,56 @@ VarHashCreateVar( * 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 check that nCleanup is constant - * and within range. */ -/* Verify the stack depth, only when no expansion is in progress */ - -#ifdef TCL_COMPILE_DEBUG -#define CHECK_STACK() \ - do { \ - ValidatePcAndStackTop(codePtr, pc, CURR_DEPTH, \ - /*checkStack*/ !(starting || auxObjList)); \ - starting = 0; \ - } while (0) -#else -#define CHECK_STACK() -#endif - -#define NEXT_INST_F(pcAdjustment, nCleanup, resultHandling) \ - do { \ - TCL_CT_ASSERT((nCleanup >= 0) && (nCleanup <= 2)); \ - CHECK_STACK(); \ - 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; \ - case 0: break; \ - } \ - } else { \ - pc += (pcAdjustment); \ - switch (nCleanup) { \ - case 1: goto cleanup1; \ - case 2: goto cleanup2; \ - case 0: break; \ - } \ - } \ - } while (0) - -#define NEXT_INST_V(pcAdjustment, nCleanup, resultHandling) \ - CHECK_STACK(); \ - 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, resultHandling) \ + 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;\ + default: Tcl_Panic("bad usage of macro NEXT_INST_F");\ + }\ + } else {\ + pc += (pcAdjustment);\ + switch (nCleanup) {\ + case 1: goto cleanup1;\ + case 2: goto cleanup2;\ + default: Tcl_Panic("bad usage of macro NEXT_INST_F");\ + }\ + } -#ifndef TCL_COMPILE_DEBUG -#define JUMP_PEEPHOLE_F(condition, pcAdjustment, cleanup) \ - do { \ - pc += (pcAdjustment); \ - switch (*pc) { \ - case INST_JUMP_FALSE1: \ - NEXT_INST_F(((condition)? 2 : TclGetInt1AtPtr(pc+1)), (cleanup), 0); \ - break; \ - case INST_JUMP_TRUE1: \ - NEXT_INST_F(((condition)? TclGetInt1AtPtr(pc+1) : 2), (cleanup), 0); \ - break; \ - case INST_JUMP_FALSE4: \ - NEXT_INST_F(((condition)? 5 : TclGetInt4AtPtr(pc+1)), (cleanup), 0); \ - break; \ - case INST_JUMP_TRUE4: \ - NEXT_INST_F(((condition)? TclGetInt4AtPtr(pc+1) : 5), (cleanup), 0); \ - break; \ - default: \ - if ((condition) < 0) { \ - TclNewIntObj(objResultPtr, -1); \ - } else { \ - objResultPtr = TCONST((condition) > 0); \ - } \ - NEXT_INST_F(0, (cleanup), 1); \ - break; \ - } \ - } while (0) -#define JUMP_PEEPHOLE_V(condition, pcAdjustment, cleanup) \ - do { \ - pc += (pcAdjustment); \ - switch (*pc) { \ - case INST_JUMP_FALSE1: \ - NEXT_INST_V(((condition)? 2 : TclGetInt1AtPtr(pc+1)), (cleanup), 0); \ - break; \ - case INST_JUMP_TRUE1: \ - NEXT_INST_V(((condition)? TclGetInt1AtPtr(pc+1) : 2), (cleanup), 0); \ - break; \ - case INST_JUMP_FALSE4: \ - NEXT_INST_V(((condition)? 5 : TclGetInt4AtPtr(pc+1)), (cleanup), 0); \ - break; \ - case INST_JUMP_TRUE4: \ - NEXT_INST_V(((condition)? TclGetInt4AtPtr(pc+1) : 5), (cleanup), 0); \ - break; \ - default: \ - if ((condition) < 0) { \ - TclNewIntObj(objResultPtr, -1); \ - } else { \ - objResultPtr = TCONST((condition) > 0); \ - } \ - NEXT_INST_V(0, (cleanup), 1); \ - break; \ - } \ - } while (0) -#else /* TCL_COMPILE_DEBUG */ -#define JUMP_PEEPHOLE_F(condition, pcAdjustment, cleanup) \ - do{ \ - if ((condition) < 0) { \ - TclNewIntObj(objResultPtr, -1); \ - } else { \ - objResultPtr = TCONST((condition) > 0); \ - } \ - NEXT_INST_F((pcAdjustment), (cleanup), 1); \ - } while (0) -#define JUMP_PEEPHOLE_V(condition, pcAdjustment, cleanup) \ - do{ \ - if ((condition) < 0) { \ - TclNewIntObj(objResultPtr, -1); \ - } else { \ - objResultPtr = TCONST((condition) > 0); \ - } \ - NEXT_INST_V((pcAdjustment), (cleanup), 1); \ - } while (0) -#endif +#define NEXT_INST_V(pcAdjustment, nCleanup, resultHandling) \ + pc += (pcAdjustment);\ + cleanup = (nCleanup);\ + if (resultHandling) {\ + if ((resultHandling) > 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() \ @@ -429,44 +284,38 @@ VarHashCreateVar( /* * Macros used to trace instruction execution. The macros TRACE, - * TRACE_WITH_OBJ, and O2S are only used inside TclNRExecuteByteCode. O2S is + * 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, "%2" TCL_SIZE_MODIFIER "d: %2" TCL_T_MODIFIER "d (%" TCL_T_MODIFIER "d) %s ", iPtr->numLevels, \ - CURR_DEPTH, \ - (pc - codePtr->codeStart), \ - GetOpcodeName(pc)); \ - printf a; \ - break; \ + if (traceInstructions) { \ + fprintf(stdout, "%2d: %2d (%u) %s ", iPtr->numLevels, \ + (int) CURR_DEPTH, \ + (unsigned)(pc - codePtr->codeStart), \ + GetOpcodeName(pc)); \ + printf a; \ } # define TRACE_APPEND(a) \ - while (traceInstructions) { \ - printf a; \ - break; \ + if (traceInstructions) { \ + printf a; \ } -# define TRACE_ERROR(interp) \ - TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); # define TRACE_WITH_OBJ(a, objPtr) \ - while (traceInstructions) { \ - fprintf(stdout, "%2" TCL_SIZE_MODIFIER "d: %2" TCL_T_MODIFIER "d (%" TCL_T_MODIFIER "d) %s ", iPtr->numLevels, \ - CURR_DEPTH, \ - (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, \ + (int) CURR_DEPTH, \ + (unsigned)(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_ERROR(interp) # define TRACE_WITH_OBJ(a, objPtr) # define O2S(objPtr) #endif /* TCL_COMPILE_DEBUG */ @@ -476,51 +325,110 @@ 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) -#define TCL_DTRACE_INST_LAST() \ - do { \ - if (TCL_DTRACE_INST_DONE_ENABLED() && curInstName) { \ + if (TCL_DTRACE_INST_DONE_ENABLED()) {\ + if (curInstName) {\ TCL_DTRACE_INST_DONE(curInstName, (int) CURR_DEPTH, tosPtr);\ - } \ - } while (0) - + }\ + 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);\ + } +#define TCL_DTRACE_INST_LAST() \ + if (TCL_DTRACE_INST_DONE_ENABLED() && curInstName) {\ + TCL_DTRACE_INST_DONE(curInstName, (int) CURR_DEPTH, tosPtr);\ + } + /* * Macro used in this file to save a function call for common uses of - * Tcl_GetNumberFromObj(). The ANSI C "prototype" is: + * TclGetNumberFromObj(). The ANSI C "prototype" is: * * MODULE_SCOPE int GetNumberFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, - * void **ptrPtr, int *tPtr); + * ClientData *ptrPtr, int *tPtr); */ -#define GetNumberFromObj(interp, objPtr, ptrPtr, tPtr) \ - ((TclHasInternalRep((objPtr), &tclIntType)) \ - ? (*(tPtr) = TCL_NUMBER_INT, \ - *(ptrPtr) = (void *) \ +#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 + +#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) : \ - TclHasInternalRep((objPtr), &tclDoubleType) \ - ? (((isnan((objPtr)->internalRep.doubleValue)) \ + ((objPtr)->typePtr == &tclDoubleType) \ + ? (((TclIsNaN((objPtr)->internalRep.doubleValue)) \ ? (*(tPtr) = TCL_NUMBER_NAN) \ : (*(tPtr) = TCL_NUMBER_DOUBLE)), \ - *(ptrPtr) = (void *) \ + *(ptrPtr) = (ClientData) \ (&((objPtr)->internalRep.doubleValue)), TCL_OK) : \ - (((objPtr)->bytes != NULL) && ((objPtr)->length == 0)) \ - ? TCL_ERROR : \ - Tcl_GetNumberFromObj((interp), (objPtr), (ptrPtr), (tPtr))) + ((((objPtr)->typePtr == NULL) && ((objPtr)->bytes == NULL)) || \ + (((objPtr)->bytes != NULL) && ((objPtr)->length == 0))) \ + ? TCL_ERROR : \ + TclGetNumberFromObj((interp), (objPtr), (ptrPtr), (tPtr))) + +#endif + +/* + * 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 +#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 /* * Macro used to make the check for type overflow more mnemonic. This works by @@ -536,20 +444,53 @@ VarHashCreateVar( #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. + * Custom object type only used in this file; values of its type should never + * be seen by user scripts. */ -#ifndef ACCEPT_NAN -#define IsErroringNaNType(type) ((type) == TCL_NUMBER_NAN) -#else -#define IsErroringNaNType(type) 0 -#endif - +static Tcl_ObjType dictIteratorType = { + "dictIterator", + NULL, NULL, NULL, NULL +}; + /* - * Auxiliary tables used to compute powers of small integers. + * 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); + +/* + * 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. + */ + +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) + /* * Maximum base that, when raised to powers 2, 3, ..., 16, fits in a * Tcl_WideInt. @@ -565,15 +506,14 @@ static const Tcl_WideInt MaxBase64[] = { static const size_t MaxBase64Size = sizeof(MaxBase64)/sizeof(Tcl_WideInt); /* - * Table giving 3, 4, ..., 13 raised to powers greater than 16 when the + *Table giving 3, 4, ..., 13 raised to powers greater than 16 when the * results fit in a 64-bit signed integer. */ 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 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, @@ -652,127 +592,56 @@ static const Tcl_WideInt Exp64Value[] = { (Tcl_WideInt)248832*248832*248832*12*12, (Tcl_WideInt)371293*371293*371293*13*13 }; -static const size_t Exp64ValueSize = sizeof(Exp64Value) / sizeof(Tcl_WideInt); +static const size_t Exp64ValueSize = sizeof(Exp64Value)/sizeof(Tcl_WideInt); -/* - * Markers for ExecuteExtendedBinaryMathOp. - */ +#endif -#define DIVIDED_BY_ZERO ((Tcl_Obj *) -1) -#define EXPONENT_OF_ZERO ((Tcl_Obj *) -2) -#define GENERAL_ARITHMETIC_ERROR ((Tcl_Obj *) -3) -#define OUT_OF_MEMORY ((Tcl_Obj *) -4) - /* * Declarations for local procedures to this file: */ #ifdef TCL_COMPILE_STATS -static Tcl_ObjCmdProc EvalStatsCmd; +static int EvalStatsCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); #endif /* TCL_COMPILE_STATS */ #ifdef TCL_COMPILE_DEBUG -static const char * GetOpcodeName(const unsigned char *pc); +static char * GetOpcodeName(unsigned char *pc); static void PrintByteCodeInfo(ByteCode *codePtr); static const char * StringForResultCode(int result); static void ValidatePcAndStackTop(ByteCode *codePtr, - const unsigned char *pc, size_t stackTop, - int checkStack); + unsigned char *pc, int stackTop, + int stackLowerBound, int checkStack); #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); -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 searchMode, ByteCode *codePtr); -static const char * GetSrcInfoForPc(const unsigned char *pc, - ByteCode *codePtr, Tcl_Size *lengthPtr, - const unsigned char **pcBeg, Tcl_Size *cmdIdxPtr); -static Tcl_Obj ** GrowEvaluationStack(ExecEnv *eePtr, TCL_HASH_TYPE growth, +static ExceptionRange * GetExceptRangeForPc(unsigned char *pc, int searchMode, + ByteCode *codePtr); +static const char * GetSrcInfoForPc(unsigned char *pc, ByteCode *codePtr, + int *lengthPtr); +static Tcl_Obj ** GrowEvaluationStack(ExecEnv *eePtr, int growth, int move); static void IllegalExprOperandType(Tcl_Interp *interp, - const unsigned char *pc, Tcl_Obj *opndPtr); + unsigned char *pc, Tcl_Obj *opndPtr); static void InitByteCodeExecution(Tcl_Interp *interp); -static inline int wordSkip(void *ptr); -static void ReleaseDictIterator(Tcl_Obj *objPtr); /* Useful elsewhere, make available in tclInt.h or stubs? */ -static Tcl_Obj ** StackAllocWords(Tcl_Interp *interp, TCL_HASH_TYPE numWords); -static Tcl_Obj ** StackReallocWords(Tcl_Interp *interp, TCL_HASH_TYPE numWords); -static Tcl_NRPostProc CopyCallback; -static Tcl_NRPostProc ExprObjCallback; -static Tcl_NRPostProc FinalizeOONext; -static Tcl_NRPostProc FinalizeOONextFilter; -static Tcl_NRPostProc TEBCresume; +static Tcl_Obj ** StackAllocWords(Tcl_Interp *interp, int numWords); +static Tcl_Obj ** StackReallocWords(Tcl_Interp *interp, int numWords); /* * 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 */ NULL, /* updateStringProc */ NULL /* setFromAnyProc */ }; - -/* - * Custom object type only used in this file; values of its type should never - * be seen by user scripts. - */ - -static const Tcl_ObjType dictIteratorType = { - "dictIterator", - ReleaseDictIterator, - NULL, NULL, NULL -}; - -/* - *---------------------------------------------------------------------- - * - * 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; - const Tcl_ObjInternalRep *irPtr; - - irPtr = TclFetchInternalRep(objPtr, &dictIteratorType); - assert(irPtr != NULL); - - /* - * First kill the search, and then release the reference to the dictionary - * that we were holding. - */ - - searchPtr = (Tcl_DictSearch *)irPtr->twoPtrValue.ptr1; - Tcl_DictObjDone(searchPtr); - ckfree(searchPtr); - - dictPtr = (Tcl_Obj *)irPtr->twoPtrValue.ptr2; - TclDecrRefCount(dictPtr); -} /* *---------------------------------------------------------------------- @@ -795,7 +664,6 @@ ReleaseDictIterator( *---------------------------------------------------------------------- */ -#if defined(TCL_COMPILE_STATS) || defined(TCL_COMPILE_DEBUG) static void InitByteCodeExecution( Tcl_Interp *interp) /* Interpreter for which the Tcl variable @@ -803,7 +671,7 @@ InitByteCodeExecution( * instruction tracing. */ { #ifdef TCL_COMPILE_DEBUG - if (Tcl_LinkVar(interp, "tcl_traceExec", &tclTraceExec, + if (Tcl_LinkVar(interp, "tcl_traceExec", (char *) &tclTraceExec, TCL_LINK_INT) != TCL_OK) { Tcl_Panic("InitByteCodeExecution: can't create link for tcl_traceExec variable"); } @@ -812,15 +680,6 @@ InitByteCodeExecution( Tcl_CreateObjCommand(interp, "evalstats", EvalStatsCmd, NULL, NULL); #endif /* TCL_COMPILE_STATS */ } - -#else - -static void -InitByteCodeExecution( - TCL_UNUSED(Tcl_Interp *)) -{ -} -#endif /* *---------------------------------------------------------------------- @@ -830,7 +689,7 @@ InitByteCodeExecution( * 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 + * recursively passed to TclExecuteByteCode to execute ByteCode sequences * for nested commands. * * Results: @@ -839,40 +698,37 @@ InitByteCodeExecution( * * Side effects: * The bytecode interpreter is also initialized here, as this procedure - * will be called before any call to TclNRExecuteByteCode. + * will be called before any call to TclExecuteByteCode. * *---------------------------------------------------------------------- */ +#define TCL_STACK_INITIAL_SIZE 2000 + ExecEnv * TclCreateExecEnv( - Tcl_Interp *interp, /* Interpreter for which the execution + Tcl_Interp *interp) /* Interpreter for which the execution * environment is being created. */ - TCL_HASH_TYPE size) /* The initial stack size, in number of words - * [sizeof(Tcl_Obj*)] */ { - ExecEnv *eePtr = (ExecEnv *)ckalloc(sizeof(ExecEnv)); - ExecStack *esPtr = (ExecStack *)ckalloc(offsetof(ExecStack, stackWords) - + size * sizeof(Tcl_Obj *)); + ExecEnv *eePtr = (ExecEnv *) ckalloc(sizeof(ExecEnv)); + ExecStack *esPtr = (ExecStack *) ckalloc(sizeof(ExecStack) + + (size_t) (TCL_STACK_INITIAL_SIZE-1) * sizeof(Tcl_Obj *)); eePtr->execStackPtr = esPtr; - TclNewIntObj(eePtr->constants[0], 0); + TclNewBooleanObj(eePtr->constants[0], 0); Tcl_IncrRefCount(eePtr->constants[0]); - TclNewIntObj(eePtr->constants[1], 1); + 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->endPtr = &esPtr->stackWords[TCL_STACK_INITIAL_SIZE-1]; esPtr->tosPtr = STACK_BASE(esPtr); Tcl_MutexLock(&execMutex); if (!execInitialized) { + TclInitAuxDataTypeTable(); InitByteCodeExecution(interp); execInitialized = 1; } @@ -880,6 +736,7 @@ TclCreateExecEnv( return eePtr; } +#undef TCL_STACK_INITIAL_SIZE /* *---------------------------------------------------------------------- @@ -902,7 +759,7 @@ static void DeleteExecStack( ExecStack *esPtr) { - if (esPtr->markerPtr && !cachedInExit) { + if (esPtr->markerPtr) { Tcl_Panic("freeing an execStack which is still in use"); } @@ -912,7 +769,7 @@ DeleteExecStack( if (esPtr->nextPtr) { esPtr->nextPtr->prevPtr = esPtr->prevPtr; } - ckfree(esPtr); + ckfree((char *) esPtr); } void @@ -921,8 +778,6 @@ TclDeleteExecEnv( { ExecStack *esPtr = eePtr->execStackPtr, *tmpPtr; - cachedInExit = TclInExit(); - /* * Delete all stacks in this exec env. */ @@ -938,13 +793,7 @@ TclDeleteExecEnv( 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"); - } - ckfree(eePtr); + ckfree((char *) eePtr); } /* @@ -971,6 +820,7 @@ TclFinalizeExecution(void) Tcl_MutexLock(&execMutex); execInitialized = 0; Tcl_MutexUnlock(&execMutex); + TclFinalizeAuxDataTypeTable(); } /* @@ -1004,9 +854,10 @@ wordSkip( * Given a marker, compute where the following aligned memory starts. */ -#define MEMSTART(markerPtr) \ +#define MEMSTART(markerPtr) \ ((markerPtr) + wordSkip(markerPtr)) + /* *---------------------------------------------------------------------- * @@ -1030,15 +881,15 @@ static Tcl_Obj ** GrowEvaluationStack( ExecEnv *eePtr, /* Points to the ExecEnv with an evaluation * stack to enlarge. */ - TCL_HASH_TYPE growth, /* How much larger than the current used + 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; - TCL_HASH_TYPE newBytes; - Tcl_Size newElems, currElems, needed = growth - (esPtr->endPtr - esPtr->tosPtr); + int newBytes, newElems, currElems; + int needed = growth - (esPtr->endPtr - esPtr->tosPtr); Tcl_Obj **markerPtr = esPtr->markerPtr, **memStart; - Tcl_Size moveWords = 0; + int moveWords = 0; if (move) { if (!markerPtr) { @@ -1048,7 +899,6 @@ GrowEvaluationStack( return MEMSTART(markerPtr); } } else { -#ifndef PURIFY Tcl_Obj **tmpMarkerPtr = esPtr->tosPtr + 1; int offset = wordSkip(tmpMarkerPtr); @@ -1065,7 +915,6 @@ GrowEvaluationStack( *esPtr->markerPtr = (Tcl_Obj *) markerPtr; return memStart; } -#endif } /* @@ -1079,7 +928,6 @@ GrowEvaluationStack( } 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!) @@ -1109,19 +957,14 @@ GrowEvaluationStack( * including the elements to be copied over and the new marker. */ -#ifndef PURIFY newElems = 2*currElems; while (needed > newElems) { newElems *= 2; } -#else - newElems = needed; -#endif - - newBytes = offsetof(ExecStack, stackWords) + newElems * sizeof(Tcl_Obj *); + newBytes = sizeof (ExecStack) + (newElems-1) * sizeof(Tcl_Obj *); oldPtr = esPtr; - esPtr = (ExecStack *)ckalloc(newBytes); + esPtr = (ExecStack *) ckalloc(newBytes); oldPtr->nextPtr = esPtr; esPtr->prevPtr = oldPtr; @@ -1181,7 +1024,7 @@ GrowEvaluationStack( static Tcl_Obj ** StackAllocWords( Tcl_Interp *interp, - TCL_HASH_TYPE numWords) + int numWords) { /* * Note that GrowEvaluationStack sets a marker in the stack. This marker @@ -1199,7 +1042,7 @@ StackAllocWords( static Tcl_Obj ** StackReallocWords( Tcl_Interp *interp, - TCL_HASH_TYPE numWords) + int numWords) { Interp *iPtr = (Interp *) interp; ExecEnv *eePtr = iPtr->execEnvPtr; @@ -1217,10 +1060,10 @@ TclStackFree( Interp *iPtr = (Interp *) interp; ExecEnv *eePtr; ExecStack *esPtr; - Tcl_Obj **markerPtr, *marker; + Tcl_Obj **markerPtr; if (iPtr == NULL || iPtr->execEnvPtr == NULL) { - ckfree(freePtr); + ckfree((char *) freePtr); return; } @@ -1233,77 +1076,62 @@ TclStackFree( 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)); + if (MEMSTART(markerPtr) != (Tcl_Obj **)freePtr) { + Tcl_Panic("TclStackFree: incorrect freePtr. Call out of sequence?"); } - esPtr->tosPtr = markerPtr - 1; - esPtr->markerPtr = (Tcl_Obj **) marker; - if (marker) { - return; + esPtr->tosPtr = markerPtr-1; + esPtr->markerPtr = (Tcl_Obj **) *markerPtr; + if (*markerPtr) { + return; } /* - * Return to previous active stack. Note that repeated expansions or - * reallocs could have generated several unused intervening stacks: free - * them too. + * Return to previous stack. */ - while (esPtr->nextPtr) { - esPtr = esPtr->nextPtr; - } esPtr->tosPtr = STACK_BASE(esPtr); - while (esPtr->prevPtr) { - ExecStack *tmpPtr = esPtr->prevPtr; - if (tmpPtr->tosPtr == STACK_BASE(tmpPtr)) { - DeleteExecStack(tmpPtr); - } else { - break; - } - } if (esPtr->prevPtr) { - eePtr->execStackPtr = esPtr->prevPtr; -#ifdef PURIFY - eePtr->execStackPtr->nextPtr = NULL; - DeleteExecStack(esPtr); -#endif - } else { - eePtr->execStackPtr = esPtr; + eePtr->execStackPtr = esPtr->prevPtr; + } + if (esPtr->nextPtr) { + if (!esPtr->prevPtr) { + eePtr->execStackPtr = esPtr->nextPtr; + } + DeleteExecStack(esPtr); } } void * TclStackAlloc( Tcl_Interp *interp, - TCL_HASH_TYPE numBytes) + int numBytes) { Interp *iPtr = (Interp *) interp; - TCL_HASH_TYPE numWords; + int numWords = (numBytes + (sizeof(Tcl_Obj *) - 1))/sizeof(Tcl_Obj *); if (iPtr == NULL || iPtr->execEnvPtr == NULL) { - return ckalloc(numBytes); + return (void *) ckalloc(numBytes); } - numWords = (numBytes + (sizeof(Tcl_Obj *) - 1))/sizeof(Tcl_Obj *); - return StackAllocWords(interp, numWords); + + return (void *) StackAllocWords(interp, numWords); } void * TclStackRealloc( Tcl_Interp *interp, void *ptr, - TCL_HASH_TYPE numBytes) + int numBytes) { Interp *iPtr = (Interp *) interp; ExecEnv *eePtr; ExecStack *esPtr; Tcl_Obj **markerPtr; - TCL_HASH_TYPE numWords; + int numWords; if (iPtr == NULL || iPtr->execEnvPtr == NULL) { - return ckrealloc((char *)ptr, numBytes); + return (void *) ckrealloc((char *) ptr, numBytes); } eePtr = iPtr->execEnvPtr; @@ -1345,153 +1173,48 @@ int Tcl_ExprObj( Tcl_Interp *interp, /* Context in which to evaluate the * expression. */ - Tcl_Obj *objPtr, /* Points to Tcl object containing 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); -} - -static int -CopyCallback( - void *data[], - TCL_UNUSED(Tcl_Interp *), - int result) -{ - Tcl_Obj **resultPtrPtr = (Tcl_Obj **)data[0]; - Tcl_Obj *resultPtr = (Tcl_Obj *)data[1]; - - if (result == TCL_OK) { - *resultPtrPtr = resultPtr; - Tcl_IncrRefCount(resultPtr); - } else { - Tcl_DecrRefCount(resultPtr); - } - 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; - Tcl_InterpState state = Tcl_SaveInterpState(interp, TCL_OK); - - Tcl_ResetResult(interp); - codePtr = CompileExprObj(interp, objPtr); - - Tcl_NRAddCallback(interp, ExprObjCallback, state, resultPtr, - NULL, NULL); - return TclNRExecuteByteCode(interp, codePtr); -} - -static int -ExprObjCallback( - void *data[], - Tcl_Interp *interp, - int result) -{ - Tcl_InterpState state = (Tcl_InterpState)data[0]; - Tcl_Obj *resultPtr = (Tcl_Obj *)data[1]; - - if (result == TCL_OK) { - TclSetDuplicateObj(resultPtr, Tcl_GetObjResult(interp)); - (void) Tcl_RestoreInterpState(interp, state); - } else { - Tcl_DiscardInterpState(state); - } - return result; -} - -/* - *---------------------------------------------------------------------- - * - * CompileExprObj -- - * Compile a Tcl expression value into ByteCode. - * - * Results: - * A (ByteCode *) is returned pointing to the resulting ByteCode. - * - * Side effects: - * The Tcl_ObjType of objPtr is changed to the "exprcode" 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. */ - ByteCode *codePtr = NULL; - /* Tcl Internal type of bytecode. Initialized + register ByteCode *codePtr = NULL; + /* Tcl Internal type of bytecode. Initialized * to avoid compiler warning. */ + int result; /* - * Get the expression ByteCode from the object. If it exists, make sure it - * is valid in the current context. + * Execute the expression after first saving the interpreter's result. */ - ByteCodeGetInternalRep(objPtr, &exprCodeType, codePtr); + Tcl_Obj *saveObjPtr = Tcl_GetObjResult(interp); + Tcl_IncrRefCount(saveObjPtr); - if (codePtr != NULL) { + /* + * 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; + codePtr = (ByteCode *) objPtr->internalRep.twoPtrValue.ptr1; if (((Interp *) *codePtr->interpHandle != iPtr) || (codePtr->compileEpoch != iPtr->compileEpoch) || (codePtr->nsPtr != namespacePtr) - || (codePtr->nsEpoch != namespacePtr->resolverEpoch) - || (codePtr->localCachePtr != iPtr->varFramePtr->localCachePtr)) { - Tcl_StoreInternalRep(objPtr, &exprCodeType, NULL); - codePtr = NULL; + || (codePtr->nsEpoch != namespacePtr->resolverEpoch)) { + objPtr->typePtr->freeIntRepProc(objPtr); + objPtr->typePtr = (Tcl_ObjType *) NULL; } } - - if (codePtr == NULL) { + if (objPtr->typePtr != &exprCodeType) { /* * TIP #280: No invoker (yet) - Expression compilation. */ - Tcl_Size length; + int length; const char *string = TclGetStringFromObj(objPtr, &length); TclInitCompileEnv(interp, &compEnv, string, length, NULL, 0); @@ -1503,7 +1226,7 @@ CompileExprObj( */ if (compEnv.codeNext == compEnv.codeStart) { - TclEmitPush(TclRegisterLiteral(&compEnv, "0", 1, 0), + TclEmitPush(TclRegisterNewLiteral(&compEnv, "0", 1), &compEnv); } @@ -1514,12 +1237,10 @@ CompileExprObj( */ TclEmitOpcode(INST_DONE, &compEnv); - codePtr = TclInitByteCodeObj(objPtr, &exprCodeType, &compEnv); + TclInitByteCodeObj(objPtr, &compEnv); + objPtr->typePtr = &exprCodeType; TclFreeCompileEnv(&compEnv); - if (iPtr->varFramePtr->localCachePtr) { - codePtr->localCachePtr = iPtr->varFramePtr->localCachePtr; - codePtr->localCachePtr->refCount++; - } + codePtr = (ByteCode *) objPtr->internalRep.twoPtrValue.ptr1; #ifdef TCL_COMPILE_DEBUG if (tclTraceCompile == 2) { TclPrintByteCodeObj(interp, objPtr); @@ -1527,7 +1248,38 @@ CompileExprObj( } #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); + } + TclDecrRefCount(saveObjPtr); + return result; } /* @@ -1536,17 +1288,17 @@ CompileExprObj( * DupExprCodeInternalRep -- * * Part of the Tcl object type implementation for Tcl expression - * bytecode. We do not copy the bytecode internalrep. 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 internalrep, - * 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. @@ -1559,8 +1311,8 @@ CompileExprObj( static void DupExprCodeInternalRep( - TCL_UNUSED(Tcl_Obj *), - TCL_UNUSED(Tcl_Obj *)) + Tcl_Obj *srcPtr, + Tcl_Obj *copyPtr) { return; } @@ -1571,15 +1323,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. *---------------------------------------------------------------------- */ @@ -1587,39 +1338,60 @@ static void FreeExprCodeInternalRep( Tcl_Obj *objPtr) { - ByteCode *codePtr; - ByteCodeGetInternalRep(objPtr, &exprCodeType, codePtr); - assert(codePtr != NULL); + ByteCode *codePtr = (ByteCode *) objPtr->internalRep.twoPtrValue.ptr1; - TclReleaseByteCode(codePtr); + codePtr->refCount--; + if (codePtr->refCount <= 0) { + TclCleanupByteCode(codePtr); + } + objPtr->typePtr = 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( +int +TclCompEvalObj( Tcl_Interp *interp, Tcl_Obj *objPtr, const CmdFrame *invoker, int word) { - Interp *iPtr = (Interp *) interp; - ByteCode *codePtr; /* Tcl Internal type of bytecode. */ - Namespace *namespacePtr = iPtr->varFramePtr->nsPtr; + register Interp *iPtr = (Interp *) interp; + register ByteCode *codePtr; /* Tcl Internal type of bytecode. */ + int result; + Namespace *namespacePtr; + + /* + * Check that the interpreter is ready to execute scripts. Note that we + * manage the interp's runlevel here: it is a small white lie (maybe), but + * saves a ++/-- pair at each invocation. Amazingly enough, the impact on + * performance is noticeable. + */ + + iPtr->numLevels++; + if (TclInterpReady(interp) == TCL_ERROR) { + result = TCL_ERROR; + goto done; + } + + namespacePtr = iPtr->varFramePtr->nsPtr; /* * If the object is not already of tclByteCodeType, compile it (and reset @@ -1627,8 +1399,7 @@ TclCompileObj( * compilation). Otherwise, check that it is "fresh" enough. */ - ByteCodeGetInternalRep(objPtr, &tclByteCodeType, codePtr); - if (codePtr != NULL) { + 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 @@ -1646,38 +1417,40 @@ TclCompileObj( * here. */ + codePtr = (ByteCode *) objPtr->internalRep.twoPtrValue.ptr1; if (((Interp *) *codePtr->interpHandle != iPtr) || (codePtr->compileEpoch != iPtr->compileEpoch) || (codePtr->nsPtr != namespacePtr) || (codePtr->nsEpoch != namespacePtr->resolverEpoch)) { - if (!(codePtr->flags & TCL_BYTECODE_PRECOMPILED)) { + if (codePtr->flags & TCL_BYTECODE_PRECOMPILED) { + if ((Interp *) *codePtr->interpHandle != iPtr) { + Tcl_Panic("Tcl_EvalObj: compiled script jumped interps"); + } + codePtr->compileEpoch = iPtr->compileEpoch; + } else { + /* + * This byteCode is invalid: free it and recompile. + */ + + objPtr->typePtr->freeIntRepProc(objPtr); goto recompileObj; } - if ((Interp *) *codePtr->interpHandle != iPtr) { - Tcl_Panic("Tcl_EvalObj: compiled script jumped interps"); - } - codePtr->compileEpoch = iPtr->compileEpoch; - } - - /* - * Check that any compiled locals do refer to the current proc - * environment! If not, recompile. - */ - - if (!(codePtr->flags & TCL_BYTECODE_PRECOMPILED) && - (codePtr->procPtr == NULL) && - (codePtr->localCachePtr != iPtr->varFramePtr->localCachePtr)){ - goto recompileObj; } /* * #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. + * because it eval-directs 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 + * It had be backported for 8.5 because we can force the separate + * compiling of a literal (in a proc body) by putting it into a control + * command with dynamic pieces, and then such literal may be shared + * and require their line-information to be reset, as for 8.6, as + * described below. + * + * 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 @@ -1688,7 +1461,7 @@ TclCompileObj( * 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 - * continuously, because the moment we have all locations we do 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 @@ -1699,67 +1472,77 @@ TclCompileObj( * information. */ - if (invoker == NULL) { - return codePtr; - } else { + if (invoker) { Tcl_HashEntry *hePtr = - Tcl_FindHashEntry(iPtr->lineBCPtr, codePtr); - ExtCmdLoc *eclPtr; - CmdFrame *ctxCopyPtr; - int redo; + Tcl_FindHashEntry(iPtr->lineBCPtr, (char *) codePtr); - if (!hePtr) { - return codePtr; - } - - eclPtr = (ExtCmdLoc *)Tcl_GetHashValue(hePtr); - redo = 0; - ctxCopyPtr = (CmdFrame *)TclStackAlloc(interp, sizeof(CmdFrame)); - *ctxCopyPtr = *invoker; + if (hePtr) { + ExtCmdLoc *eclPtr = Tcl_GetHashValue(hePtr); + int redo = 0; + CmdFrame *ctxPtr = TclStackAlloc(interp,sizeof(CmdFrame)); - if (invoker->type == TCL_LOCATION_BC) { - /* - * Note: Type BC => ctx.data.eval.path is not used. - * ctx.data.tebc.codePtr used instead - */ + *ctxPtr = *invoker; - TclGetSrcInfoForPc(ctxCopyPtr); - if (ctxCopyPtr->type == TCL_LOCATION_SOURCE) { + if (invoker->type == TCL_LOCATION_BC) { /* - * The reference made by 'TclGetSrcInfoForPc' is dead. + * Note: Type BC => ctx.data.eval.path is not used. + * ctx.data.tebc.codePtr used instead */ - Tcl_DecrRefCount(ctxCopyPtr->data.eval.path); - ctxCopyPtr->data.eval.path = NULL; + TclGetSrcInfoForPc(ctxPtr); + if (ctxPtr->type == TCL_LOCATION_SOURCE) { + /* + * The reference made by 'TclGetSrcInfoForPc' is + * dead. + */ + + Tcl_DecrRefCount(ctxPtr->data.eval.path); + ctxPtr->data.eval.path = NULL; + } } - } - if (word < ctxCopyPtr->nline) { - /* - * 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 ...). - */ + if (word < ctxPtr->nline) { + /* + * 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 ...). + */ - redo = ((eclPtr->type == TCL_LOCATION_SOURCE) - && (eclPtr->start != ctxCopyPtr->line[word])) + redo = ((eclPtr->type == TCL_LOCATION_SOURCE) + && (eclPtr->start != ctxPtr->line[word])) || ((eclPtr->type == TCL_LOCATION_BC) - && (ctxCopyPtr->type == TCL_LOCATION_SOURCE)); - } + && (ctxPtr->type == TCL_LOCATION_SOURCE)); + } - TclStackFree(interp, ctxCopyPtr); - if (!redo) { - return codePtr; + TclStackFree(interp, ctxPtr); + + if (redo) { + goto recompileObj; + } } } + + /* + * Increment the code's ref count while it is being executed. If + * afterwards no references to it remain, free the code. + */ + + runCompiledObj: + codePtr->refCount++; + result = TclExecuteByteCode(interp, codePtr); + codePtr->refCount--; + if (codePtr->refCount <= 0) { + TclCleanupByteCode(codePtr); + } + goto done; } - recompileObj: + recompileObj: iPtr->errorLine = 1; /* @@ -1771,14 +1554,14 @@ TclCompileObj( iPtr->invokeCmdFramePtr = invoker; iPtr->invokeWord = word; - TclSetByteCodeFromAny(interp, objPtr, NULL, NULL); + tclByteCodeType.setFromAnyProc(interp, objPtr); iPtr->invokeCmdFramePtr = NULL; - ByteCodeGetInternalRep(objPtr, &tclByteCodeType, codePtr); - if (iPtr->varFramePtr->localCachePtr) { - codePtr->localCachePtr = iPtr->varFramePtr->localCachePtr; - codePtr->localCachePtr->refCount++; - } - return codePtr; + codePtr = (ByteCode *) objPtr->internalRep.twoPtrValue.ptr1; + goto runCompiledObj; + + done: + iPtr->numLevels--; + return result; } /* @@ -1786,7 +1569,7 @@ TclCompileObj( * * TclIncrObj -- * - * Increment an integral value in a Tcl_Obj by an integral value held + * 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. * @@ -1796,7 +1579,7 @@ TclCompileObj( * of course). * * Side effects: - * valuePtr gets the new incremented value. + * valuePtr gets the new incrmented value. * *---------------------------------------------------------------------- */ @@ -1807,10 +1590,9 @@ TclIncrObj( Tcl_Obj *valuePtr, Tcl_Obj *incrPtr) { - void *ptr1, *ptr2; + ClientData ptr1, ptr2; int type1, type2; mp_int value, incr; - mp_err err; if (Tcl_IsShared(valuePtr)) { Tcl_Panic("%s called with shared object", "TclIncrObj"); @@ -1833,6 +1615,37 @@ TclIncrObj( 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; + } +#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?!) @@ -1850,30 +1663,29 @@ TclIncrObj( return TCL_ERROR; } - if ((type1 == TCL_NUMBER_INT) && (type2 == TCL_NUMBER_INT)) { +#ifndef NO_WIDE_TYPE + if ((type1 != TCL_NUMBER_BIG) && (type2 != TCL_NUMBER_BIG)) { Tcl_WideInt w1, w2, sum; - w1 = *((const Tcl_WideInt *)ptr1); - w2 = *((const Tcl_WideInt *)ptr2); - sum = (Tcl_WideInt)((Tcl_WideUInt)w1 + (Tcl_WideUInt)w2); + TclGetWideIntFromObj(NULL, valuePtr, &w1); + TclGetWideIntFromObj(NULL, incrPtr, &w2); + sum = w1 + w2; /* * Check for overflow. */ if (!Overflowing(w1, w2, sum)) { - TclSetIntObj(valuePtr, sum); + Tcl_SetWideIntObj(valuePtr, sum); return TCL_OK; } } +#endif Tcl_TakeBignumFromObj(interp, valuePtr, &value); Tcl_GetBignumFromObj(interp, incrPtr, &incr); - err = mp_add(&value, &incr, &value); + mp_add(&value, &incr, &value); mp_clear(&incr); - if (err != MP_OKAY) { - return TCL_ERROR; - } Tcl_SetBignumObj(valuePtr, &value); return TCL_OK; } @@ -1881,42 +1693,7 @@ TclIncrObj( /* *---------------------------------------------------------------------- * - * ArgumentBCEnter -- - * - * This is a helper for TclNRExecuteByteCode/TEBCresume that encapsulates - * a code sequence that is fairly common in the code but *not* commonly - * called. - * - * Results: - * None - * - * Side effects: - * May register information about the bytecode in the command frame. - * - *---------------------------------------------------------------------- - */ - -static void -ArgumentBCEnter( - Tcl_Interp *interp, - ByteCode *codePtr, - TEBCdata *tdPtr, - const unsigned char *pc, - Tcl_Size objc, - Tcl_Obj **objv) -{ - Tcl_Size cmd; - - if (GetSrcInfoForPc(pc, codePtr, NULL, NULL, &cmd)) { - TclArgumentBCEnter(interp, objv, objc, codePtr, &tdPtr->cmdFrame, cmd, - pc - codePtr->codeStart); - } -} - -/* - *---------------------------------------------------------------------- - * - * TclNRExecuteByteCode -- + * TclExecuteByteCode -- * * This procedure executes the instructions of a ByteCode structure. It * returns when a "done" instruction is executed or an error occurs. @@ -1931,96 +1708,12 @@ ArgumentBCEnter( * *---------------------------------------------------------------------- */ -#define bcFramePtr (&TD->cmdFrame) -#define initCatchTop (TD->stack-1) -#define initTosPtr (initCatchTop+codePtr->maxExceptDepth) -#define esPtr (iPtr->execEnvPtr->execStackPtr) int -TclNRExecuteByteCode( +TclExecuteByteCode( Tcl_Interp *interp, /* Token for command interpreter. */ ByteCode *codePtr) /* The bytecode sequence to interpret. */ { - Interp *iPtr = (Interp *) interp; - TEBCdata *TD; - TCL_HASH_TYPE size = sizeof(TEBCdata) - 1 - + (codePtr->maxStackDepth + codePtr->maxExceptDepth) - * sizeof(void *); - TCL_HASH_TYPE numWords = (size + sizeof(Tcl_Obj *) - 1) / sizeof(Tcl_Obj *); - - TclPreserveByteCode(codePtr); - - /* - * 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->catchTop = initCatchTop; - TD->auxObjList = NULL; - - /* - * 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->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->cmdObj = NULL; - bcFramePtr->cmd = NULL; - bcFramePtr->len = 0; - -#ifdef TCL_COMPILE_STATS - iPtr->stats.numExecutions++; -#endif - - /* - * Test namespace-50.9 demonstrates the need for this call. - * Use a --enable-symbols=mem bug to see. - */ - - TclResetRewriteEnsemble(interp, 1); - - /* - * Push the callback for bytecode execution - */ - - TclNRAddCallback(interp, TEBCresume, TD, /* pc */ NULL, - /* cleanup */ NULL, INT2PTR(iPtr->evalFlags)); - - /* - * Reset discard result flag - because it is applicable for this call only, - * and should not affect all the nested invocations may return result. - */ - iPtr->evalFlags &= ~TCL_EVAL_DISCARD_RESULT; - - return TCL_OK; -} - -static int -TEBCresume( - void *data[], - Tcl_Interp *interp, - int result) -{ /* * Compiler cast directive - not a real variable. * Interp *iPtr = (Interp *) interp; @@ -2033,178 +1726,118 @@ TEBCresume( #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. + * sporadically. */ - unsigned interruptCounter = 1; - /* Counter that is used to work out when to - * call Tcl_AsyncReady(). This must be 1 - * initially so that we call the async-check - * stanza early, otherwise there are command - * sequences that can make the interpreter - * busy-loop without an opportunity to - * recognise an interrupt. */ - const char *curInstName; -#ifdef TCL_COMPILE_DEBUG - int traceInstructions; /* Whether we are doing instruction-level - * tracing or not. */ -#endif - - Var *compiledLocals = iPtr->varFramePtr->compiledLocals; + ExecStack *esPtr; + Tcl_Obj **initTosPtr; /* Stack top at start of execution. */ + ptrdiff_t *initCatchTop; /* Catch stack top at start of execution. */ + Var *compiledLocals; + Namespace *namespacePtr; + CmdFrame *bcFramePtr; /* TIP #280: Structure for tracking lines. */ Tcl_Obj **constants = &iPtr->execEnvPtr->constants[0]; -#define LOCAL(i) (&compiledLocals[(i)]) -#define TCONST(i) (constants[(i)]) - - /* - * These macros are just meant to save some global variables that are not - * used too frequently - */ - - TEBCdata *TD = (TEBCdata *)data[0]; -#define auxObjList (TD->auxObjList) -#define catchTop (TD->catchTop) -#define codePtr (TD->codePtr) -#define curEvalFlags PTR2INT(data[3]) /* calling iPtr->evalFlags */ - /* * Globals: variables that store state, must remain valid at all times. */ - Tcl_Obj **tosPtr; /* Cached pointer to top of evaluation + ptrdiff_t *catchTop; + register Tcl_Obj **tosPtr; /* Cached pointer to top of evaluation * stack. */ - const unsigned char *pc = (const unsigned char *)data[1]; - /* The current program counter. */ - unsigned char inst; /* The currently running instruction */ + register unsigned char *pc = codePtr->codeStart; + /* The current program counter. */ + int instructionCount = 0; /* Counter that is used to work out when to + * call Tcl_AsyncReady() */ + Tcl_Obj *expandNestList = NULL; + int checkInterp = 0; /* Indicates when a check of interp readyness + * is necessary. Set by CACHE_STACK_INFO() */ /* * Transfer variables - needed only between opcodes, but not while * executing an instruction. */ - int cleanup = PTR2INT(data[2]); + register int cleanup; Tcl_Obj *objResultPtr; - int checkInterp = 0; /* Indicates when a check of interp readyness - * is necessary. Set by CACHE_STACK_INFO() */ + + /* + * Result variable - needed only when going to checkForcatch or other + * error handlers; also used as local in some opcodes. + */ + + int result = TCL_OK; /* Return code returned after execution. */ /* * 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. + * NOTE: These are now defined locally where needed. */ - Tcl_Obj *objPtr, *valuePtr, *value2Ptr, *part1Ptr, *part2Ptr, *tmpPtr; - Tcl_Obj **objv = NULL; - Tcl_Size length, objc = 0; - int opnd, pcAdjustment; - Var *varPtr, *arrayPtr; #ifdef TCL_COMPILE_DEBUG + int traceInstructions = (tclTraceExec == 3); char cmdNameBuf[21]; #endif + const char *curInstName = NULL; -#ifdef TCL_COMPILE_DEBUG - int starting = 1; - traceInstructions = (tclTraceExec == 3); -#endif + /* + * The execution uses a unified stack: first the catch stack, immediately + * above it a CmdFrame, 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. + */ - TEBC_DATA_DIG(); + catchTop = initCatchTop = (ptrdiff_t *) ( + GrowEvaluationStack(iPtr->execEnvPtr, + (sizeof(CmdFrame) + sizeof(Tcl_Obj *) - 1)/sizeof(Tcl_Obj *) + + codePtr->maxExceptDepth + codePtr->maxStackDepth, 0) - 1); + bcFramePtr = (CmdFrame *) (initCatchTop + codePtr->maxExceptDepth + 1); + tosPtr = initTosPtr = ((Tcl_Obj **) (bcFramePtr + 1)) - 1; + esPtr = iPtr->execEnvPtr->execStackPtr; + + /* + * TIP #280: Initialize the frame. Do not push it yet. + */ + + bcFramePtr->type = ((codePtr->flags & TCL_BYTECODE_PRECOMPILED) + ? TCL_LOCATION_PREBC : TCL_LOCATION_BC); + bcFramePtr->level = (iPtr->cmdFramePtr ? iPtr->cmdFramePtr->level+1 : 1); + bcFramePtr->framePtr = iPtr->framePtr; + bcFramePtr->nextPtr = iPtr->cmdFramePtr; + bcFramePtr->nline = 0; + bcFramePtr->line = NULL; + + bcFramePtr->data.tebc.codePtr = codePtr; + bcFramePtr->data.tebc.pc = NULL; + bcFramePtr->cmd.str.cmd = NULL; + bcFramePtr->cmd.str.len = 0; #ifdef TCL_COMPILE_DEBUG - if (!pc && (tclTraceExec >= 2)) { + if (tclTraceExec >= 2) { PrintByteCodeInfo(codePtr); - fprintf(stdout, " Starting stack top=%" TCL_T_MODIFIER "d\n", CURR_DEPTH); + fprintf(stdout, " Starting stack top=%d\n", (int) CURR_DEPTH); fflush(stdout); } #endif - if (!pc) { - /* bytecode is starting from scratch */ - pc = codePtr->codeStart; - - /* - * Reset the interp's result to avoid possible duplications of large - * objects [3c6e47363e], [781585], [804681], This can happen by start - * also in nested compiled blocks (enclosed in parent cycle). - * See else branch below for opposite handling by continuation/resume. - */ - - objPtr = iPtr->objResultPtr; - if (objPtr->refCount > 1) { - TclDecrRefCount(objPtr); - TclNewObj(objPtr); - Tcl_IncrRefCount(objPtr); - iPtr->objResultPtr = objPtr; - } - - goto cleanup0; - } else { - /* resume from invocation */ - CACHE_STACK_INFO(); - - NRE_ASSERT(iPtr->cmdFramePtr == bcFramePtr); - if (bcFramePtr->cmdObj) { - Tcl_DecrRefCount(bcFramePtr->cmdObj); - bcFramePtr->cmdObj = NULL; - bcFramePtr->cmd = NULL; - } - iPtr->cmdFramePtr = bcFramePtr->nextPtr; - if (iPtr->flags & INTERP_DEBUG_FRAME) { - TclArgumentBCRelease(interp, bcFramePtr); - } - if (iPtr->execEnvPtr->rewind) { - result = TCL_ERROR; - goto abnormalReturn; - } - if (codePtr->flags & TCL_BYTECODE_RECOMPILE) { - codePtr->flags &= ~TCL_BYTECODE_RECOMPILE; - checkInterp = 1; - iPtr->flags |= ERR_ALREADY_LOGGED; - } - - if (result != TCL_OK) { - pc--; - goto processExceptionReturn; - } - - /* - * Push the call's object result and continue execution with the next - * instruction. - */ +#ifdef TCL_COMPILE_STATS + iPtr->stats.numExecutions++; +#endif - TRACE_WITH_OBJ(("%" TCL_SIZE_MODIFIER "d => ... after \"%.20s\": TCL_OK, result=", - objc, cmdNameBuf), Tcl_GetObjResult(interp)); + namespacePtr = iPtr->varFramePtr->nsPtr; + compiledLocals = iPtr->varFramePtr->compiledLocals; - /* - * Obtain and reset interp's result to avoid possible duplications of - * 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. - */ + /* + * Loop executing instructions until a "done" instruction, a TCL_RETURN, + * or some error. + */ - objResultPtr = Tcl_GetObjResult(interp); - TclNewObj(objPtr); - Tcl_IncrRefCount(objPtr); - iPtr->objResultPtr = objPtr; -#ifndef TCL_COMPILE_DEBUG - if (*pc == INST_POP) { - TclDecrRefCount(objResultPtr); - NEXT_INST_V(1, cleanup, 0); - } -#endif - NEXT_INST_V(0, cleanup, -1); - } + goto cleanup0; /* * Targets for standard instruction endings; unrolled for speed in the @@ -2215,92 +1848,114 @@ TEBCresume( * cleanup. */ - cleanupV_pushObjResultPtr: - switch (cleanup) { - case 0: - *(++tosPtr) = (objResultPtr); + { + Tcl_Obj *valuePtr; + + cleanupV_pushObjResultPtr: + switch (cleanup) { + case 0: + *(++tosPtr) = (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 = OBJ_AT_TOS; + TclDecrRefCount(valuePtr); + } + OBJ_AT_TOS = objResultPtr; goto cleanup0; - default: - cleanup -= 2; - while (cleanup--) { - objPtr = POP_OBJECT(); - TclDecrRefCount(objPtr); + + cleanupV: + switch (cleanup) { + 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; } - /* FALLTHRU */ - case 2: - cleanup2_pushObjResultPtr: - objPtr = POP_OBJECT(); - TclDecrRefCount(objPtr); - /* FALLTHRU */ - case 1: - cleanup1_pushObjResultPtr: - objPtr = OBJ_AT_TOS; - TclDecrRefCount(objPtr); } - OBJ_AT_TOS = objResultPtr; - goto cleanup0; + cleanup0: - cleanupV: - switch (cleanup) { - default: - cleanup -= 2; - while (cleanup--) { - objPtr = POP_OBJECT(); - TclDecrRefCount(objPtr); - } - /* FALLTHRU */ - case 2: - cleanup2: - objPtr = POP_OBJECT(); - TclDecrRefCount(objPtr); - /* FALLTHRU */ - case 1: - cleanup1: - objPtr = POP_OBJECT(); - TclDecrRefCount(objPtr); - /* FALLTHRU */ - case 0: - /* - * We really want to do nothing now, but this is needed for some - * compilers (SunPro CC). - */ +#ifdef TCL_COMPILE_DEBUG + /* + * Skip the stack depth check if an expansion is in progress. + */ - break; + ValidatePcAndStackTop(codePtr, pc, CURR_DEPTH, 0, + /*checkStack*/ expandNestList == NULL); + if (traceInstructions) { + fprintf(stdout, "%2d: %2d ", iPtr->numLevels, (int) CURR_DEPTH); + TclPrintInstruction(codePtr, pc); + fflush(stdout); } - cleanup0: +#endif /* TCL_COMPILE_DEBUG */ + +#ifdef TCL_COMPILE_STATS + iPtr->stats.instructionCount[*pc]++; +#endif /* * Check for asynchronous handlers [Bug 746722]; we do the check every - * ASYNC_CHECK_COUNT instructions. + * ASYNC_CHECK_COUNT_MASK instruction, of the form (2**n-1). */ - if ((--interruptCounter) == 0) { - interruptCounter = ASYNC_CHECK_COUNT; - DECACHE_STACK_INFO(); + if ((instructionCount++ & ASYNC_CHECK_COUNT_MASK) == 0) { + /* + * Check for asynchronous handlers [Bug 746722]; we do the check every + * ASYNC_CHECK_COUNT_MASK instruction, of the form (2**n-<1). + */ + if (TclAsyncReady(iPtr)) { - result = Tcl_AsyncInvoke(interp, result); - if (result == TCL_ERROR) { - CACHE_STACK_INFO(); - goto gotError; - } - } + int localResult; - if (TclCanceled(iPtr)) { - if (Tcl_Canceled(interp, TCL_LEAVE_ERR_MSG) == TCL_ERROR) { - CACHE_STACK_INFO(); - goto gotError; + DECACHE_STACK_INFO(); + localResult = Tcl_AsyncInvoke(interp, result); + CACHE_STACK_INFO(); + if (localResult == TCL_ERROR) { + result = localResult; + goto checkForCatch; } } - if (TclLimitReady(iPtr->limit)) { - if (Tcl_LimitCheck(interp) == TCL_ERROR) { - CACHE_STACK_INFO(); - goto gotError; + int localResult; + + DECACHE_STACK_INFO(); + localResult = Tcl_LimitCheck(interp); + CACHE_STACK_INFO(); + if (localResult == TCL_ERROR) { + result = localResult; + goto checkForCatch; } } - CACHE_STACK_INFO(); } + TCL_DTRACE_INST_NEXT(); + /* * These two instructions account for 26% of all instructions (according * to measurements on tclbench by Ben Vitale @@ -2310,62 +1965,13 @@ TEBCresume( * reduces total obj size. */ - inst = *pc; - - peepholeStart: -#ifdef TCL_COMPILE_STATS - iPtr->stats.instructionCount[*pc]++; -#endif - -#ifdef TCL_COMPILE_DEBUG - /* - * Skip the stack depth check if an expansion is in progress. - */ - - CHECK_STACK(); - if (traceInstructions) { - fprintf(stdout, "%2" TCL_SIZE_MODIFIER "d: %2" TCL_T_MODIFIER "d ", iPtr->numLevels, CURR_DEPTH); - TclPrintInstruction(codePtr, pc); - fflush(stdout); - } -#endif /* TCL_COMPILE_DEBUG */ - - TCL_DTRACE_INST_NEXT(); - - if (inst == INST_LOAD_SCALAR1) { + if (*pc == INST_LOAD_SCALAR1) { goto instLoadScalar1; - } else if (inst == INST_PUSH1) { - PUSH_OBJECT(codePtr->objArrayPtr[TclGetUInt1AtPtr(pc+1)]); - TRACE_WITH_OBJ(("%u => ", TclGetUInt1AtPtr(pc+1)), OBJ_AT_TOS); - inst = *(pc += 2); - goto peepholeStart; - } else if (inst == INST_START_CMD) { - /* - * Peephole: do not run INST_START_CMD, just skip it - */ - - iPtr->cmdCount += TclGetUInt4AtPtr(pc+5); - if (checkInterp) { - if (((codePtr->compileEpoch != iPtr->compileEpoch) || - (codePtr->nsEpoch != iPtr->varFramePtr->nsPtr->resolverEpoch)) && - !(codePtr->flags & TCL_BYTECODE_PRECOMPILED)) { - goto instStartCmdFailed; - } - checkInterp = 0; - } - inst = *(pc += 9); - goto peepholeStart; - } else if (inst == INST_NOP) { -#ifndef TCL_COMPILE_DEBUG - while (inst == INST_NOP) -#endif - { - inst = *++pc; - } - goto peepholeStart; + } else if (*pc == INST_PUSH1) { + goto instPush1Peephole; } - switch (inst) { + switch (*pc) { case INST_SYNTAX: case INST_RETURN_IMM: { int code = TclGetInt4AtPtr(pc+1); @@ -2378,215 +1984,37 @@ TEBCresume( 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\")\n", + TRACE_APPEND(("continuing to next instruction (result=\"%.30s\")", O2S(objResultPtr))); NEXT_INST_F(9, 1, 0); + } else { + Tcl_SetObjResult(interp, OBJ_UNDER_TOS); + if (*pc == INST_SYNTAX) { + iPtr->flags &= ~ERR_ALREADY_LOGGED; + } + cleanup = 2; + goto processExceptionReturn; } - Tcl_SetObjResult(interp, OBJ_UNDER_TOS); - if (*pc == INST_SYNTAX) { - iPtr->flags &= ~ERR_ALREADY_LOGGED; - } - cleanup = 2; - TRACE_APPEND(("\n")); - 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) { - Tcl_DecrRefCount(OBJ_AT_TOS); - OBJ_AT_TOS = objResultPtr; - TRACE_APPEND(("continuing to next instruction (result=\"%.30s\")\n", + TRACE_APPEND(("continuing to next instruction (result=\"%.30s\")", O2S(objResultPtr))); NEXT_INST_F(1, 0, 0); - } else if (result == TCL_ERROR) { - /* - * BEWARE! Must do this in this order, because an error in the - * option dictionary overrides the result (and can be verified by - * test). - */ - - Tcl_SetObjResult(interp, objResultPtr); - Tcl_SetReturnOptions(interp, OBJ_AT_TOS); - Tcl_DecrRefCount(OBJ_AT_TOS); - OBJ_AT_TOS = objResultPtr; } else { - Tcl_DecrRefCount(OBJ_AT_TOS); - OBJ_AT_TOS = objResultPtr; Tcl_SetObjResult(interp, objResultPtr); + cleanup = 1; + goto processExceptionReturn; } - cleanup = 1; - TRACE_APPEND(("\n")); - goto processExceptionReturn; - - { - CoroutineData *corPtr; - void *yieldParameter; - - case INST_YIELD: - corPtr = iPtr->execEnvPtr->corPtr; - TRACE(("%.30s => ", O2S(OBJ_AT_TOS))); - if (!corPtr) { - TRACE_APPEND(("ERROR: yield outside coroutine\n")); - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "yield can only be called in a coroutine", -1)); - DECACHE_STACK_INFO(); - Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "ILLEGAL_YIELD", - (void *)NULL); - CACHE_STACK_INFO(); - goto gotError; - } - -#ifdef TCL_COMPILE_DEBUG - if (tclTraceExec >= 2) { - if (traceInstructions) { - TRACE_APPEND(("YIELD...\n")); - } else { - fprintf(stdout, "%" TCL_SIZE_MODIFIER "d: (%" TCL_T_MODIFIER "d) yielding value \"%.30s\"\n", - iPtr->numLevels, (pc - codePtr->codeStart), - Tcl_GetString(OBJ_AT_TOS)); - } - fflush(stdout); - } -#endif - yieldParameter = NULL; /*==CORO_ACTIVATE_YIELD*/ - Tcl_SetObjResult(interp, OBJ_AT_TOS); - goto doYield; - - case INST_YIELD_TO_INVOKE: - corPtr = iPtr->execEnvPtr->corPtr; - valuePtr = OBJ_AT_TOS; - if (!corPtr) { - TRACE(("[%.30s] => ERROR: yield outside coroutine\n", - O2S(valuePtr))); - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "yieldto can only be called in a coroutine", -1)); - DECACHE_STACK_INFO(); - Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "ILLEGAL_YIELD", - (void *)NULL); - CACHE_STACK_INFO(); - goto gotError; - } - if (((Namespace *)TclGetCurrentNamespace(interp))->flags & NS_DYING) { - TRACE(("[%.30s] => ERROR: yield in deleted\n", - O2S(valuePtr))); - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "yieldto called in deleted namespace", -1)); - DECACHE_STACK_INFO(); - Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "YIELDTO_IN_DELETED", - (void *)NULL); - CACHE_STACK_INFO(); - goto gotError; - } - -#ifdef TCL_COMPILE_DEBUG - if (tclTraceExec >= 2) { - if (traceInstructions) { - TRACE(("[%.30s] => YIELD...\n", O2S(valuePtr))); - } else { - /* FIXME: What is the right thing to trace? */ - fprintf(stdout, "%" TCL_SIZE_MODIFIER "d: (%" TCL_T_MODIFIER "d) yielding to [%.30s]\n", - iPtr->numLevels, (pc - codePtr->codeStart), - TclGetString(valuePtr)); - } - fflush(stdout); - } -#endif - - /* - * Install a tailcall record in the caller and continue with the - * yield. The yield is switched into multi-return mode (via the - * 'yieldParameter'). - */ - - iPtr->execEnvPtr = corPtr->callerEEPtr; - Tcl_IncrRefCount(valuePtr); - TclSetTailcall(interp, valuePtr); - corPtr->yieldPtr = valuePtr; - iPtr->execEnvPtr = corPtr->eePtr; - yieldParameter = INT2PTR(1); /*==CORO_ACTIVATE_YIELDM*/ - - doYield: - /* TIP #280: Record the last piece of info needed by - * 'TclGetSrcInfoForPc', and push the frame. - */ - - bcFramePtr->data.tebc.pc = (char *) pc; - iPtr->cmdFramePtr = bcFramePtr; - - if (iPtr->flags & INTERP_DEBUG_FRAME) { - ArgumentBCEnter(interp, codePtr, TD, pc, objc, objv); - } - - pc++; - cleanup = 1; - TEBC_YIELD(); - TclNRAddCallback(interp, TclNRCoroutineActivateCallback, corPtr, - yieldParameter, NULL, NULL); - return TCL_OK; - } - - case INST_TAILCALL: { - Tcl_Obj *listPtr, *nsObjPtr; - - opnd = TclGetUInt1AtPtr(pc+1); - - if (!(iPtr->varFramePtr->isProcCallFrame & 1)) { - TRACE(("%d => ERROR: tailcall in non-proc context\n", opnd)); - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "tailcall can only be called from a proc or lambda", -1)); - DECACHE_STACK_INFO(); - Tcl_SetErrorCode(interp, "TCL", "TAILCALL", "ILLEGAL", (void *)NULL); - CACHE_STACK_INFO(); - goto gotError; - } - -#ifdef TCL_COMPILE_DEBUG - /* FIXME: What is the right thing to trace? */ - { - int i; - - TRACE(("%d [", opnd)); - for (i=opnd-1 ; i>=0 ; i--) { - TRACE_APPEND(("\"%.30s\"", O2S(OBJ_AT_DEPTH(i)))); - if (i > 0) { - TRACE_APPEND((" ")); - } - } - TRACE_APPEND(("] => RETURN...")); - } -#endif - - /* - * Push the evaluation of the called command into the NR callback - * stack. - */ - - listPtr = Tcl_NewListObj(opnd, &OBJ_AT_DEPTH(opnd-1)); - nsObjPtr = Tcl_NewStringObj(iPtr->varFramePtr->nsPtr->fullName, -1); - TclListObjSetElement(interp, listPtr, 0, nsObjPtr); - if (iPtr->varFramePtr->tailcallPtr) { - Tcl_DecrRefCount(iPtr->varFramePtr->tailcallPtr); - } - iPtr->varFramePtr->tailcallPtr = listPtr; - - result = TCL_RETURN; - cleanup = opnd; - goto processExceptionReturn; - } case INST_DONE: if (tosPtr > initTosPtr) { - - if ((curEvalFlags & TCL_EVAL_DISCARD_RESULT) && (result == TCL_OK)) { - /* simulate pop & fast done (like it does continue in loop) */ - TRACE_WITH_OBJ(("=> discarding "), OBJ_AT_TOS); - objPtr = POP_OBJECT(); - TclDecrRefCount(objPtr); - goto abnormalReturn; - } /* * Set the interpreter's object result to point to the topmost * object from the stack, and check for a possible [catch]. The @@ -2603,82 +2031,227 @@ TEBCresume( } #endif goto checkForCatch; + } else { + (void) POP_OBJECT(); + 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. + */ + + if (*pc == INST_PUSH1) { + TCL_DTRACE_INST_NEXT(); + goto instPush1Peephole; + } +#endif + NEXT_INST_F(0, 0, 0); case INST_PUSH4: objResultPtr = codePtr->objArrayPtr[TclGetUInt4AtPtr(pc+1)]; TRACE_WITH_OBJ(("%u => ", TclGetUInt4AtPtr(pc+1)), objResultPtr); NEXT_INST_F(5, 0, 1); - break; - case INST_POP: + case INST_POP: { + Tcl_Obj *valuePtr; + TRACE_WITH_OBJ(("=> discarding "), OBJ_AT_TOS); - objPtr = POP_OBJECT(); - TclDecrRefCount(objPtr); - NEXT_INST_F(1, 0, 0); - break; + valuePtr = POP_OBJECT(); + TclDecrRefCount(valuePtr); + + /* + * 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) { + instStartCmdOK: + NEXT_INST_F(9, 0, 0); + } else if (((codePtr->compileEpoch == iPtr->compileEpoch) + && (codePtr->nsEpoch == namespacePtr->resolverEpoch)) + || (codePtr->flags & TCL_BYTECODE_PRECOMPILED)) { + checkInterp = 0; + goto instStartCmdOK; + } else { + const char *bytes; + int length, opnd; + Tcl_Obj *newObjResultPtr; + + bytes = GetSrcInfoForPc(pc, codePtr, &length); + DECACHE_STACK_INFO(); + result = Tcl_EvalEx(interp, bytes, length, 0); + CACHE_STACK_INFO(); + if (result != TCL_OK) { + cleanup = 0; + if (result == TCL_ERROR) { + /* + * Tcl_EvalEx already did the task of logging + * the error to the stack trace for us, so set + * a flag to prevent the TEBC exception handling + * machinery from trying to do it again. + * Tcl Bug 2037338. See test execute-8.4. + */ + iPtr->flags |= ERR_ALREADY_LOGGED; + } + goto processExceptionReturn; + } + opnd = TclGetUInt4AtPtr(pc+1); + objResultPtr = Tcl_GetObjResult(interp); + TclNewObj(newObjResultPtr); + Tcl_IncrRefCount(newObjResultPtr); + iPtr->objResultPtr = newObjResultPtr; + NEXT_INST_V(opnd, 0, -1); + } case INST_DUP: objResultPtr = OBJ_AT_TOS; TRACE_WITH_OBJ(("=> "), objResultPtr); NEXT_INST_F(1, 0, 1); - break; - case INST_OVER: + case INST_OVER: { + int opnd; + opnd = TclGetUInt4AtPtr(pc+1); objResultPtr = OBJ_AT_DEPTH(opnd); - TRACE_WITH_OBJ(("%u => ", opnd), objResultPtr); + TRACE_WITH_OBJ(("=> "), objResultPtr); NEXT_INST_F(5, 0, 1); - break; + } case INST_REVERSE: { + int opnd; Tcl_Obj **a, **b; opnd = TclGetUInt4AtPtr(pc+1); a = tosPtr-(opnd-1); b = tosPtr; while (a<b) { - tmpPtr = *a; + Tcl_Obj *temp = *a; *a = *b; - *b = tmpPtr; + *b = temp; a++; b--; } - TRACE(("%u => OK\n", opnd)); NEXT_INST_F(5, 0, 0); } - break; - case INST_STR_CONCAT1: + case INST_CONCAT1: { + int opnd, length, appendLen = 0; + char *bytes, *p; + Tcl_Obj **currPtr; opnd = TclGetUInt1AtPtr(pc+1); - objResultPtr = TclStringCat(interp, opnd, &OBJ_AT_DEPTH(opnd-1), - TCL_STRING_IN_PLACE); - if (objResultPtr == NULL) { - TRACE_ERROR(interp); - goto gotError; + + /* + * Compute the length to be appended. + */ + + for (currPtr=&OBJ_AT_DEPTH(opnd-2); + appendLen >= 0 && currPtr<=&OBJ_AT_TOS; currPtr++) { + bytes = TclGetStringFromObj(*currPtr, &length); + if (bytes != NULL) { + appendLen += length; + } } - TRACE_WITH_OBJ(("%u => ", opnd), objResultPtr); - NEXT_INST_V(2, opnd, 1); - break; + if (appendLen < 0) { + /* TODO: convert panic to error ? */ + Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); + } - case INST_CONCAT_STK: /* - * Pop the opnd (objc) top stack elements, run through Tcl_ConcatObj, - * and then decrement their ref counts. + * 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 {}]'. */ - opnd = TclGetUInt4AtPtr(pc+1); - objResultPtr = Tcl_ConcatObj(opnd, &OBJ_AT_DEPTH(opnd-1)); + 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); + 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->typePtr = NULL; + objResultPtr->bytes = ckrealloc(bytes, (length + appendLen + 1)); + objResultPtr->length = length + appendLen; + p = TclGetString(objResultPtr) + length; + currPtr = &OBJ_AT_DEPTH(opnd - 2); + } else { +#endif + p = (char *) ckalloc((unsigned) (length + appendLen + 1)); + TclNewObj(objResultPtr); + objResultPtr->bytes = p; + objResultPtr->length = length + appendLen; + currPtr = &OBJ_AT_DEPTH(opnd - 1); +#if !TCL_COMPILE_DEBUG + } +#endif + + /* + * Append the remaining characters. + */ + + for (; currPtr <= &OBJ_AT_TOS; currPtr++) { + bytes = TclGetStringFromObj(*currPtr, &length); + if (bytes != NULL) { + memcpy(p, bytes, (size_t) length); + p += length; + } + } + *p = '\0'; + TRACE_WITH_OBJ(("%u => ", opnd), objResultPtr); - NEXT_INST_V(5, opnd, 1); - break; + NEXT_INST_V(2, opnd, 1); + } - case INST_EXPAND_START: + case INST_EXPAND_START: { /* - * Push an element to the auxObjList. This records the current + * Push an element to the expandNestList. This records the current * stack depth - i.e., the point in the stack where the expanded * command starts. * @@ -2690,35 +2263,19 @@ TEBCresume( * error, also in INST_EXPAND_STKTOP). */ + Tcl_Obj *objPtr; + TclNewObj(objPtr); - objPtr->internalRep.twoPtrValue.ptr2 = INT2PTR(CURR_DEPTH); - objPtr->length = 0; - PUSH_TAUX_OBJ(objPtr); - TRACE(("=> mark depth as %" TCL_T_MODIFIER "d\n", CURR_DEPTH)); + objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) CURR_DEPTH; + objPtr->internalRep.twoPtrValue.ptr2 = (VOID *) expandNestList; + expandNestList = objPtr; NEXT_INST_F(1, 0, 0); - break; - - case INST_EXPAND_DROP: - /* - * Drops an element of the auxObjList, popping stack elements to - * restore the stack to the state before the point where the aux - * element was created. - */ - - CLANG_ASSERT(auxObjList); - objc = CURR_DEPTH - PTR2INT(auxObjList->internalRep.twoPtrValue.ptr2); - POP_TAUX_OBJ(); -#ifdef TCL_COMPILE_DEBUG - /* Ugly abuse! */ - starting = 1; -#endif - TRACE(("=> drop %" TCL_SIZE_MODIFIER "d items\n", objc)); - NEXT_INST_V(1, objc, 0); + } case INST_EXPAND_STKTOP: { - Tcl_Size i; - TEBCdata *newTD; - ptrdiff_t oldCatchTopOff, oldTosPtrOff; + int objc, length, i; + Tcl_Obj **objv, *valuePtr; + ptrdiff_t moved; /* * Make sure that the element at stackTop is a list; if not, just @@ -2726,11 +2283,12 @@ TEBCresume( * will be removed at checkForCatch. */ - objPtr = OBJ_AT_TOS; - TRACE(("\"%.30s\" => ", O2S(objPtr))); - if (TclListObjGetElements(interp, objPtr, &objc, &objv) != TCL_OK) { - TRACE_ERROR(interp); - goto gotError; + valuePtr = OBJ_AT_TOS; + if (TclListObjGetElements(interp, valuePtr, &objc, &objv) != TCL_OK){ + TRACE_WITH_OBJ(("%.30s => ERROR: ", O2S(valuePtr)), + Tcl_GetObjResult(interp)); + result = TCL_ERROR; + goto checkForCatch; } (void) POP_OBJECT(); @@ -2741,28 +2299,22 @@ TEBCresume( * stack depth, as seen by the compiler. */ - auxObjList->length += objc - 1; - if ((objc > 1) && (auxObjList->length > 0)) { - length = auxObjList->length /* Total expansion room we need */ - + codePtr->maxStackDepth /* Beyond the original max */ - - CURR_DEPTH; /* Relative to where we are */ - DECACHE_STACK_INFO(); - oldCatchTopOff = catchTop - initCatchTop; - oldTosPtrOff = tosPtr - initTosPtr; - newTD = (TEBCdata *) - GrowEvaluationStack(iPtr->execEnvPtr, length, 1); - if (newTD != TD) { - /* - * 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. - */ + length = objc + (codePtr->maxStackDepth - TclGetInt4AtPtr(pc+1)); + DECACHE_STACK_INFO(); + moved = (GrowEvaluationStack(iPtr->execEnvPtr, length, 1) - 1) + - (Tcl_Obj **) initCatchTop; - TD = newTD; + if (moved) { + /* + * Change the global data to point to the new stack. + */ - catchTop = initCatchTop + oldCatchTopOff; - tosPtr = initTosPtr + oldTosPtrOff; - } + initCatchTop += moved; + catchTop += moved; + bcFramePtr = (CmdFrame *) (initCatchTop + codePtr->maxExceptDepth + 1); + initTosPtr += moved; + tosPtr += moved; + esPtr = iPtr->execEnvPtr->execStackPtr; } /* @@ -2774,59 +2326,38 @@ TEBCresume( PUSH_OBJECT(objv[i]); } - TRACE_APPEND(("OK\n")); - Tcl_DecrRefCount(objPtr); + Tcl_DecrRefCount(valuePtr); NEXT_INST_F(5, 0, 0); } - break; - - case INST_EXPR_STK: { - ByteCode *newCodePtr; - - 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); - } + { /* * INVOCATION BLOCK */ - case INST_EVAL_STK: - instEvalStk: - bcFramePtr->data.tebc.pc = (char *) pc; - iPtr->cmdFramePtr = bcFramePtr; - - cleanup = 1; - pc += 1; - /* yield next instruction */ - TEBC_YIELD(); - /* add TEBCResume for object at top of stack */ - return TclNRExecuteByteCode(interp, - TclCompileObj(interp, OBJ_AT_TOS, NULL, 0)); + int objc, pcAdjustment; case INST_INVOKE_EXPANDED: - CLANG_ASSERT(auxObjList); - objc = CURR_DEPTH - PTR2INT(auxObjList->internalRep.twoPtrValue.ptr2); - POP_TAUX_OBJ(); + { + Tcl_Obj *objPtr = expandNestList; + + expandNestList = (Tcl_Obj *) objPtr->internalRep.twoPtrValue.ptr2; + objc = CURR_DEPTH + - (ptrdiff_t) objPtr->internalRep.twoPtrValue.ptr1; + TclDecrRefCount(objPtr); + } + if (objc) { pcAdjustment = 1; goto doInvocation; - } - - /* - * Nothing was expanded, return {}. - */ + } else { + /* + * Nothing was expanded, return {}. + */ - TclNewObj(objResultPtr); - NEXT_INST_F(1, 0, 1); - break; + TclNewObj(objResultPtr); + NEXT_INST_F(1, 0, 1); + } case INST_INVOKE_STK4: objc = TclGetUInt4AtPtr(pc+1); @@ -2838,52 +2369,103 @@ TEBCresume( pcAdjustment = 2; doInvocation: - objv = &OBJ_AT_DEPTH(objc-1); - cleanup = objc; + { + Tcl_Obj **objv = &OBJ_AT_DEPTH(objc-1); #ifdef TCL_COMPILE_DEBUG - if (tclTraceExec >= 2) { - Tcl_Size i; + if (tclTraceExec >= 2) { + int i; - if (traceInstructions) { - strncpy(cmdNameBuf, TclGetString(objv[0]), 20); - TRACE(("%" TCL_SIZE_MODIFIER "d => call ", objc)); - } else { - fprintf(stdout, "%" TCL_SIZE_MODIFIER "d: (%" TCL_T_MODIFIER "d) invoking ", iPtr->numLevels, - (pc - codePtr->codeStart)); - } - for (i = 0; i < objc; i++) { - TclPrintObject(stdout, objv[i], 15); - fprintf(stdout, " "); + if (traceInstructions) { + strncpy(cmdNameBuf, TclGetString(objv[0]), 20); + TRACE(("%u => call ", objc)); + } else { + fprintf(stdout, "%d: (%u) invoking ", iPtr->numLevels, + (unsigned)(pc - codePtr->codeStart)); + } + for (i = 0; i < objc; i++) { + TclPrintObject(stdout, objv[i], 15); + fprintf(stdout, " "); + } + fprintf(stdout, "\n"); + fflush(stdout); } - fprintf(stdout, "\n"); - fflush(stdout); - } #endif /*TCL_COMPILE_DEBUG*/ - /* - * Finally, let TclEvalObjv handle the command. - * - * TIP #280: Record the last piece of info needed by - * 'TclGetSrcInfoForPc', and push the frame. - */ + /* + * Reset the instructionCount variable, since we're about to check + * for async stuff anyway while processing TclEvalObjvInternal. + */ - bcFramePtr->data.tebc.pc = (char *) pc; - iPtr->cmdFramePtr = bcFramePtr; + instructionCount = 1; - if (iPtr->flags & INTERP_DEBUG_FRAME) { - ArgumentBCEnter(interp, codePtr, TD, pc, objc, objv); - } + /* + * Finally, let TclEvalObjvInternal handle the command. + * + * TIP #280: Record the last piece of info needed by + * 'TclGetSrcInfoForPc', and push the frame. + */ - DECACHE_STACK_INFO(); + 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); + } + DECACHE_STACK_INFO(); + result = TclEvalObjvInternal(interp, objc, objv, + /* call from TEBC */(char *) -1, -1, 0); + CACHE_STACK_INFO(); + if (iPtr->flags & INTERP_DEBUG_FRAME) { + TclArgumentBCRelease((Tcl_Interp *) iPtr, objv, objc, + codePtr, pc - codePtr->codeStart); + } + iPtr->cmdFramePtr = iPtr->cmdFramePtr->nextPtr; + + if (result == TCL_OK) { + Tcl_Obj *objPtr; + + /* + * Push the call's object result and continue execution with + * the next instruction. + */ - pc += pcAdjustment; - TEBC_YIELD(); - return TclNREvalObjv(interp, objc, objv, - TCL_EVAL_NOERR | TCL_EVAL_SOURCE_IN_FRAME, NULL); + 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; +#ifndef TCL_COMPILE_DEBUG + if (*(pc+pcAdjustment) == INST_POP) { + TclDecrRefCount(objResultPtr); + NEXT_INST_V((pcAdjustment+1), objc, 0); + } +#endif + NEXT_INST_V(pcAdjustment, objc, -1); + } else { + cleanup = objc; + goto processExceptionReturn; + } + } #if TCL_SUPPORT_84_BYTECODE - case INST_CALL_BUILTIN_FUNC1: + 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 @@ -2891,45 +2473,47 @@ TEBCresume( * function into the stack. */ + int opnd, numArgs; + Tcl_Obj *objPtr; + 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); + Tcl_Panic("TclExecuteByteCode: unrecognized builtin function code %d", opnd); } - TclNewLiteralStringObj(objPtr, "::tcl::mathfunc::"); + objPtr = Tcl_NewStringObj("::tcl::mathfunc::", 17); Tcl_AppendToObj(objPtr, tclBuiltinFuncTable[opnd].name, -1); /* * Only 0, 1 or 2 args. */ - { - int numArgs = tclBuiltinFuncTable[opnd].numArgs; + numArgs = tclBuiltinFuncTable[opnd].numArgs; + if (numArgs == 0) { + PUSH_OBJECT(objPtr); + } else if (numArgs == 1) { + Tcl_Obj *tmpPtr1 = POP_OBJECT(); + PUSH_OBJECT(objPtr); + PUSH_OBJECT(tmpPtr1); + Tcl_DecrRefCount(tmpPtr1); + } else { 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); - } - objc = numArgs + 1; + tmpPtr2 = POP_OBJECT(); + tmpPtr1 = POP_OBJECT(); + PUSH_OBJECT(objPtr); + PUSH_OBJECT(tmpPtr1); + PUSH_OBJECT(tmpPtr2); + Tcl_DecrRefCount(tmpPtr1); + Tcl_DecrRefCount(tmpPtr2); } + + objc = numArgs + 1; pcAdjustment = 2; goto doInvocation; + } - case INST_CALL_FUNC1: + 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 @@ -2937,11 +2521,16 @@ TEBCresume( * ::tcl::mathfunc::$objv[0]. */ - objc = TclGetUInt1AtPtr(pc+1); /* Number of arguments. The function - * name is the 0-th argument. */ + Tcl_Obj *tmpPtr, *objPtr; + + /* + * Number of arguments. The function name is the 0-th argument. + */ + + objc = TclGetUInt1AtPtr(pc+1); objPtr = OBJ_AT_DEPTH(objc-1); - TclNewLiteralStringObj(tmpPtr, "::tcl::mathfunc::"); + tmpPtr = Tcl_NewStringObj("::tcl::mathfunc::", 17); Tcl_AppendObjToObj(tmpPtr, objPtr); Tcl_DecrRefCount(objPtr); @@ -2954,6 +2543,7 @@ TEBCresume( pcAdjustment = 2; goto doInvocation; + } #else /* * INST_CALL_BUILTIN_FUNC1 and INST_CALL_FUNC1 were made obsolete by the @@ -2962,86 +2552,98 @@ TEBCresume( */ case INST_CALL_BUILTIN_FUNC1: - Tcl_Panic("TclNRExecuteByteCode: obsolete INST_CALL_BUILTIN_FUNC1 found"); + Tcl_Panic("TclExecuteByteCode: obsolete INST_CALL_BUILTIN_FUNC1 found"); case INST_CALL_FUNC1: - Tcl_Panic("TclNRExecuteByteCode: obsolete INST_CALL_FUNC1 found"); + Tcl_Panic("TclExecuteByteCode: obsolete INST_CALL_FUNC1 found"); #endif + } - case INST_INVOKE_REPLACE: - objc = TclGetUInt4AtPtr(pc+1); - opnd = TclGetUInt1AtPtr(pc+5); - objPtr = POP_OBJECT(); - objv = &OBJ_AT_DEPTH(objc-1); - cleanup = objc; -#ifdef TCL_COMPILE_DEBUG - if (tclTraceExec >= 2) { - Tcl_Size i; + case INST_EVAL_STK: { + /* + * Note to maintainers: it is important that INST_EVAL_STK pop its + * argument from the stack before jumping to checkForCatch! DO NOT + * OPTIMISE! + */ - if (traceInstructions) { - strncpy(cmdNameBuf, TclGetString(objv[0]), 20); - TRACE(("%" TCL_SIZE_MODIFIER "d => call (implementation %s) ", objc, O2S(objPtr))); - } else { - fprintf(stdout, - "%" TCL_SIZE_MODIFIER "d: (%" TCL_T_MODIFIER "d) invoking (using implementation %s) ", - iPtr->numLevels, (pc - codePtr->codeStart), - O2S(objPtr)); - } - for (i = 0; i < objc; i++) { - if (i < opnd) { - fprintf(stdout, "<"); - TclPrintObject(stdout, objv[i], 15); - fprintf(stdout, ">"); - } else { - TclPrintObject(stdout, objv[i], 15); - } - fprintf(stdout, " "); - } - fprintf(stdout, "\n"); - fflush(stdout); - } -#endif /*TCL_COMPILE_DEBUG*/ + Tcl_Obj *objPtr = OBJ_AT_TOS; - bcFramePtr->data.tebc.pc = (char *) pc; - iPtr->cmdFramePtr = bcFramePtr; - if (iPtr->flags & INTERP_DEBUG_FRAME) { - ArgumentBCEnter(interp, codePtr, TD, pc, objc, objv); - } + DECACHE_STACK_INFO(); - TclInitRewriteEnsemble(interp, opnd, 1, objv); + /* + * TIP #280: The invoking context is left NULL for a dynamically + * constructed command. We cannot match its lines to the outer + * context. + */ - { - Tcl_Obj *copyPtr = Tcl_NewListObj(objc - opnd + 1, NULL); + result = TclCompEvalObj(interp, objPtr, NULL, 0); + CACHE_STACK_INFO(); + if (result == TCL_OK) { + /* + * Normal return; push the eval's object result. + */ - Tcl_ListObjAppendElement(NULL, copyPtr, objPtr); - Tcl_ListObjReplace(NULL, copyPtr, LIST_MAX, 0, - objc - opnd, objv + opnd); - Tcl_DecrRefCount(objPtr); - objPtr = copyPtr; + objResultPtr = Tcl_GetObjResult(interp); + TRACE_WITH_OBJ(("\"%.30s\" => ", O2S(objPtr)), + 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_F(1, 1, -1); + } else { + cleanup = 1; + goto processExceptionReturn; } + } - DECACHE_STACK_INFO(); - pc += 6; - TEBC_YIELD(); + case INST_EXPR_STK: { + Tcl_Obj *objPtr, *valuePtr; - TclMarkTailcall(interp); - TclNRAddCallback(interp, TclClearRootEnsemble, NULL, NULL, NULL, NULL); - TclListObjGetElements(NULL, objPtr, &objc, &objv); - TclNRAddCallback(interp, TclNRReleaseValues, objPtr, NULL, NULL, NULL); - return TclNREvalObjv(interp, objc, objv, TCL_EVAL_INVOKE, NULL); + objPtr = OBJ_AT_TOS; + DECACHE_STACK_INFO(); + /*Tcl_ResetResult(interp);*/ + result = Tcl_ExprObj(interp, objPtr, &valuePtr); + CACHE_STACK_INFO(); + if (result == TCL_OK) { + objResultPtr = valuePtr; + TRACE_WITH_OBJ(("\"%.30s\" => ", O2S(objPtr)), valuePtr); + NEXT_INST_F(1, 1, -1); /* Already has right refct. */ + } else { + TRACE_WITH_OBJ(("\"%.30s\" => ERROR: ", O2S(objPtr)), + Tcl_GetObjResult(interp)); + goto checkForCatch; + } + } /* - * ----------------------------------------------------------------- + * --------------------------------------------------------- * 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. */ + { + int opnd, pcAdjustment; + Tcl_Obj *part1Ptr, *part2Ptr; + Var *varPtr, *arrayPtr; + Tcl_Obj *objPtr; case INST_LOAD_SCALAR1: instLoadScalar1: opnd = TclGetUInt1AtPtr(pc+1); - varPtr = LOCAL(opnd); + varPtr = &(compiledLocals[opnd]); while (TclIsVarLink(varPtr)) { varPtr = varPtr->value.linkPtr; } @@ -3063,7 +2665,7 @@ TEBCresume( case INST_LOAD_SCALAR4: opnd = TclGetUInt4AtPtr(pc+1); - varPtr = LOCAL(opnd); + varPtr = &(compiledLocals[opnd]); while (TclIsVarLink(varPtr)) { varPtr = varPtr->value.linkPtr; } @@ -3095,7 +2697,7 @@ TEBCresume( doLoadArray: part1Ptr = NULL; part2Ptr = OBJ_AT_TOS; - arrayPtr = LOCAL(opnd); + arrayPtr = &(compiledLocals[opnd]); while (TclIsVarLink(arrayPtr)) { arrayPtr = arrayPtr->value.linkPtr; } @@ -3115,8 +2717,10 @@ TEBCresume( varPtr = TclLookupArrayElement(interp, part1Ptr, part2Ptr, TCL_LEAVE_ERR_MSG, "read", 0, 1, arrayPtr, opnd); if (varPtr == NULL) { - TRACE_ERROR(interp); - goto gotError; + TRACE_APPEND(("ERROR: %.30s\n", + O2S(Tcl_GetObjResult(interp)))); + result = TCL_ERROR; + goto checkForCatch; } cleanup = 1; goto doCallPtrGetVar; @@ -3140,22 +2744,24 @@ TEBCresume( varPtr = TclObjLookupVarEx(interp, part1Ptr, part2Ptr, TCL_LEAVE_ERR_MSG, "read", /*createPart1*/0, /*createPart2*/1, &arrayPtr); - if (!varPtr) { - TRACE_ERROR(interp); - goto gotError; - } - - if (TclIsVarDirectReadable2(varPtr, arrayPtr)) { - /* - * No errors, no traces: just get the value. - */ + if (varPtr) { + if (TclIsVarDirectReadable2(varPtr, arrayPtr)) { + /* + * No errors, no traces: just get the value. + */ - objResultPtr = varPtr->value.objPtr; - TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); - NEXT_INST_V(1, cleanup, 1); + objResultPtr = varPtr->value.objPtr; + TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); + NEXT_INST_V(1, cleanup, 1); + } + pcAdjustment = 1; + opnd = -1; + goto doCallPtrGetVar; + } else { + TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); + result = TCL_ERROR; + goto checkForCatch; } - pcAdjustment = 1; - opnd = -1; doCallPtrGetVar: /* @@ -3164,19 +2770,26 @@ TEBCresume( */ DECACHE_STACK_INFO(); - objResultPtr = TclPtrGetVarIdx(interp, varPtr, arrayPtr, + objResultPtr = TclPtrGetVar(interp, varPtr, arrayPtr, part1Ptr, part2Ptr, TCL_LEAVE_ERR_MSG, opnd); CACHE_STACK_INFO(); - if (!objResultPtr) { - TRACE_ERROR(interp); - goto gotError; + if (objResultPtr) { + TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); + NEXT_INST_V(pcAdjustment, cleanup, 1); + } else { + TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); + result = TCL_ERROR; + goto checkForCatch; } - 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 @@ -3185,8 +2798,10 @@ TEBCresume( */ { - int storeFlags; - Tcl_Size len; + int opnd, pcAdjustment, storeFlags; + Tcl_Obj *part1Ptr, *part2Ptr; + Var *varPtr, *arrayPtr; + Tcl_Obj *objPtr, *valuePtr; case INST_STORE_ARRAY4: opnd = TclGetUInt4AtPtr(pc+1); @@ -3200,7 +2815,7 @@ TEBCresume( doStoreArrayDirect: valuePtr = OBJ_AT_TOS; part2Ptr = OBJ_UNDER_TOS; - arrayPtr = LOCAL(opnd); + arrayPtr = &(compiledLocals[opnd]); TRACE(("%u \"%.30s\" <- \"%.30s\" => ", opnd, O2S(part2Ptr), O2S(valuePtr))); while (TclIsVarLink(arrayPtr)) { @@ -3231,40 +2846,39 @@ TEBCresume( doStoreScalarDirect: valuePtr = OBJ_AT_TOS; - varPtr = LOCAL(opnd); + varPtr = &(compiledLocals[opnd]); TRACE(("%u <- \"%.30s\" => ", opnd, O2S(valuePtr))); while (TclIsVarLink(varPtr)) { varPtr = varPtr->value.linkPtr; } - if (!TclIsVarDirectWritable(varPtr)) { - storeFlags = TCL_LEAVE_ERR_MSG; - part1Ptr = NULL; - goto doStoreScalar; - } - - /* - * 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. - */ - + if (TclIsVarDirectWritable(varPtr)) { doStoreVarDirect: - valuePtr = varPtr->value.objPtr; - if (valuePtr != NULL) { - TclDecrRefCount(valuePtr); - } - objResultPtr = OBJ_AT_TOS; - varPtr->value.objPtr = objResultPtr; + /* + * 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; + 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); - } + if (*(pc+pcAdjustment) == INST_POP) { + tosPtr--; + NEXT_INST_F((pcAdjustment+1), 0, 0); + } #else - TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); + TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); #endif - Tcl_IncrRefCount(objResultPtr); - NEXT_INST_F(pcAdjustment, 0, 0); + Tcl_IncrRefCount(objResultPtr); + NEXT_INST_F(pcAdjustment, 0, 0); + } + storeFlags = TCL_LEAVE_ERR_MSG; + part1Ptr = NULL; + goto doStoreScalar; case INST_LAPPEND_STK: valuePtr = OBJ_AT_TOS; /* value to append */ @@ -3317,14 +2931,16 @@ TEBCresume( #endif varPtr = TclObjLookupVarEx(interp, objPtr,part2Ptr, TCL_LEAVE_ERR_MSG, "set", /*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr); - if (!varPtr) { - TRACE_ERROR(interp); - goto gotError; + if (varPtr) { + cleanup = ((part2Ptr == NULL)? 2 : 3); + pcAdjustment = 1; + opnd = -1; + goto doCallPtrSetVar; + } else { + TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); + result = TCL_ERROR; + goto checkForCatch; } - cleanup = ((part2Ptr == NULL)? 2 : 3); - pcAdjustment = 1; - opnd = -1; - goto doCallPtrSetVar; case INST_LAPPEND_ARRAY4: opnd = TclGetUInt4AtPtr(pc+1); @@ -3355,7 +2971,7 @@ TEBCresume( doStoreArray: valuePtr = OBJ_AT_TOS; part2Ptr = OBJ_UNDER_TOS; - arrayPtr = LOCAL(opnd); + arrayPtr = &(compiledLocals[opnd]); TRACE(("%u \"%.30s\" <- \"%.30s\" => ", opnd, O2S(part2Ptr), O2S(valuePtr))); while (TclIsVarLink(arrayPtr)) { @@ -3367,11 +2983,13 @@ TEBCresume( doStoreArrayDirectFailed: varPtr = TclLookupArrayElement(interp, part1Ptr, part2Ptr, TCL_LEAVE_ERR_MSG, "set", 1, 1, arrayPtr, opnd); - if (!varPtr) { - TRACE_ERROR(interp); - goto gotError; + if (varPtr) { + goto doCallPtrSetVar; + } else { + TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); + result = TCL_ERROR; + goto checkForCatch; } - goto doCallPtrSetVar; case INST_LAPPEND_SCALAR4: opnd = TclGetUInt4AtPtr(pc+1); @@ -3401,7 +3019,7 @@ TEBCresume( doStoreScalar: valuePtr = OBJ_AT_TOS; - varPtr = LOCAL(opnd); + varPtr = &(compiledLocals[opnd]); TRACE(("%u <- \"%.30s\" => ", opnd, O2S(valuePtr))); while (TclIsVarLink(varPtr)) { varPtr = varPtr->value.linkPtr; @@ -3412,206 +3030,49 @@ TEBCresume( doCallPtrSetVar: DECACHE_STACK_INFO(); - objResultPtr = TclPtrSetVarIdx(interp, varPtr, arrayPtr, + objResultPtr = TclPtrSetVar(interp, varPtr, arrayPtr, part1Ptr, part2Ptr, valuePtr, storeFlags, opnd); CACHE_STACK_INFO(); - if (!objResultPtr) { - TRACE_ERROR(interp); - goto gotError; - } + if (objResultPtr) { #ifndef TCL_COMPILE_DEBUG - if (*(pc+pcAdjustment) == INST_POP) { - NEXT_INST_V((pcAdjustment+1), cleanup, 0); - } -#endif - TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); - NEXT_INST_V(pcAdjustment, cleanup, 1); - - case INST_LAPPEND_LIST: - opnd = TclGetUInt4AtPtr(pc+1); - valuePtr = OBJ_AT_TOS; - varPtr = LOCAL(opnd); - cleanup = 1; - pcAdjustment = 5; - while (TclIsVarLink(varPtr)) { - varPtr = varPtr->value.linkPtr; - } - TRACE(("%u <- \"%.30s\" => ", opnd, O2S(valuePtr))); - if (TclListObjGetElements(interp, valuePtr, &objc, &objv) - != TCL_OK) { - TRACE_ERROR(interp); - goto gotError; - } - if (TclIsVarDirectReadable(varPtr) - && TclIsVarDirectWritable(varPtr)) { - goto lappendListDirect; - } - arrayPtr = NULL; - part1Ptr = part2Ptr = NULL; - goto lappendListPtr; - - case INST_LAPPEND_LIST_ARRAY: - opnd = TclGetUInt4AtPtr(pc+1); - valuePtr = OBJ_AT_TOS; - part1Ptr = NULL; - part2Ptr = OBJ_UNDER_TOS; - arrayPtr = LOCAL(opnd); - cleanup = 2; - pcAdjustment = 5; - while (TclIsVarLink(arrayPtr)) { - arrayPtr = arrayPtr->value.linkPtr; - } - TRACE(("%u \"%.30s\" \"%.30s\" => ", - opnd, O2S(part2Ptr), O2S(valuePtr))); - if (TclListObjGetElements(interp, valuePtr, &objc, &objv) - != TCL_OK) { - TRACE_ERROR(interp); - goto gotError; - } - if (TclIsVarArray(arrayPtr) && !ReadTraced(arrayPtr) - && !WriteTraced(arrayPtr)) { - varPtr = VarHashFindVar(arrayPtr->value.tablePtr, part2Ptr); - if (varPtr && TclIsVarDirectReadable(varPtr) - && TclIsVarDirectWritable(varPtr)) { - goto lappendListDirect; - } - } - varPtr = TclLookupArrayElement(interp, part1Ptr, part2Ptr, - TCL_LEAVE_ERR_MSG, "set", 1, 1, arrayPtr, opnd); - if (varPtr == NULL) { - TRACE_ERROR(interp); - goto gotError; - } - goto lappendListPtr; - - case INST_LAPPEND_LIST_ARRAY_STK: - pcAdjustment = 1; - cleanup = 3; - valuePtr = OBJ_AT_TOS; - part2Ptr = OBJ_UNDER_TOS; /* element name */ - part1Ptr = OBJ_AT_DEPTH(2); /* array name */ - TRACE(("\"%.30s(%.30s)\" \"%.30s\" => ", - O2S(part1Ptr), O2S(part2Ptr), O2S(valuePtr))); - goto lappendList; - - case INST_LAPPEND_LIST_STK: - pcAdjustment = 1; - cleanup = 2; - valuePtr = OBJ_AT_TOS; - part2Ptr = NULL; - part1Ptr = OBJ_UNDER_TOS; /* variable name */ - TRACE(("\"%.30s\" \"%.30s\" => ", O2S(part1Ptr), O2S(valuePtr))); - goto lappendList; - - lappendListDirect: - objResultPtr = varPtr->value.objPtr; - if (TclListObjLength(interp, objResultPtr, &len) != TCL_OK) { - TRACE_ERROR(interp); - goto gotError; - } - if (Tcl_IsShared(objResultPtr)) { - Tcl_Obj *newValue = Tcl_DuplicateObj(objResultPtr); - - TclDecrRefCount(objResultPtr); - varPtr->value.objPtr = objResultPtr = newValue; - Tcl_IncrRefCount(newValue); - } - if (TclListObjAppendElements(interp, objResultPtr, objc, objv) - != TCL_OK) { - TRACE_ERROR(interp); - goto gotError; - } - TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); - NEXT_INST_V(pcAdjustment, cleanup, 1); - - lappendList: - opnd = -1; - if (TclListObjGetElements(interp, valuePtr, &objc, &objv) - != TCL_OK) { - TRACE_ERROR(interp); - goto gotError; - } - DECACHE_STACK_INFO(); - varPtr = TclObjLookupVarEx(interp, part1Ptr, part2Ptr, - TCL_LEAVE_ERR_MSG, "set", 1, 1, &arrayPtr); - CACHE_STACK_INFO(); - if (!varPtr) { - TRACE_ERROR(interp); - goto gotError; - } - - lappendListPtr: - if (TclIsVarInHash(varPtr)) { - VarHashRefCount(varPtr)++; - } - if (arrayPtr && TclIsVarInHash(arrayPtr)) { - VarHashRefCount(arrayPtr)++; - } - DECACHE_STACK_INFO(); - objResultPtr = TclPtrGetVarIdx(interp, varPtr, arrayPtr, - part1Ptr, part2Ptr, TCL_LEAVE_ERR_MSG, opnd); - CACHE_STACK_INFO(); - if (TclIsVarInHash(varPtr)) { - VarHashRefCount(varPtr)--; - } - if (arrayPtr && TclIsVarInHash(arrayPtr)) { - VarHashRefCount(arrayPtr)--; - } - - { - int createdNewObj = 0; - Tcl_Obj *valueToAssign; - - if (!objResultPtr) { - valueToAssign = valuePtr; - } else if (TclListObjLength(interp, objResultPtr, &len)!=TCL_OK) { - TRACE_ERROR(interp); - goto gotError; - } else { - if (Tcl_IsShared(objResultPtr)) { - valueToAssign = Tcl_DuplicateObj(objResultPtr); - createdNewObj = 1; - } else { - valueToAssign = objResultPtr; - } - if (TclListObjAppendElements(interp, valueToAssign, - objc, objv) != TCL_OK) { - if (createdNewObj) { - TclDecrRefCount(valueToAssign); - } - goto errorInLappendListPtr; - } - } - DECACHE_STACK_INFO(); - objResultPtr = TclPtrSetVarIdx(interp, varPtr, arrayPtr, part1Ptr, - part2Ptr, valueToAssign, TCL_LEAVE_ERR_MSG, opnd); - CACHE_STACK_INFO(); - if (!objResultPtr) { - errorInLappendListPtr: - TRACE_ERROR(interp); - goto gotError; + if (*(pc+pcAdjustment) == INST_POP) { + NEXT_INST_V((pcAdjustment+1), cleanup, 0); } +#endif + TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); + NEXT_INST_V(pcAdjustment, cleanup, 1); + } else { + TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); + result = TCL_ERROR; + goto checkForCatch; } - 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 some + * instructions set the value of some variables and then jump to somme * common execution code. */ /*TODO: Consider more untangling here; merge with LOAD and STORE ? */ { - Tcl_Obj *incrPtr; + Tcl_Obj *objPtr, *incrPtr; + int opnd, pcAdjustment; +#ifndef NO_WIDE_TYPE Tcl_WideInt w; - long increment; +#endif + long i; + Tcl_Obj *part1Ptr, *part2Ptr; + Var *varPtr, *arrayPtr; case INST_INCR_SCALAR1: case INST_INCR_ARRAY1: @@ -3635,8 +3096,8 @@ TEBCresume( case INST_INCR_ARRAY_STK_IMM: case INST_INCR_SCALAR_STK_IMM: case INST_INCR_STK_IMM: - increment = TclGetInt1AtPtr(pc+1); - TclNewIntObj(incrPtr, increment); + i = TclGetInt1AtPtr(pc+1); + incrPtr = Tcl_NewIntObj(i); Tcl_IncrRefCount(incrPtr); pcAdjustment = 2; @@ -3646,112 +3107,151 @@ TEBCresume( part2Ptr = OBJ_AT_TOS; objPtr = OBJ_UNDER_TOS; TRACE(("\"%.30s(%.30s)\" (by %ld) => ", - O2S(objPtr), O2S(part2Ptr), increment)); + O2S(objPtr), O2S(part2Ptr), i)); } else { part2Ptr = NULL; objPtr = OBJ_AT_TOS; - TRACE(("\"%.30s\" (by %ld) => ", O2S(objPtr), increment)); + 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) { - DECACHE_STACK_INFO(); - Tcl_AddErrorInfo(interp, - "\n (reading value of variable to increment)"); - CACHE_STACK_INFO(); - TRACE_ERROR(interp); + if (varPtr) { + cleanup = ((part2Ptr == NULL)? 1 : 2); + goto doIncrVar; + } else { + Tcl_AddObjErrorInfo(interp, + "\n (reading value of variable to increment)", -1); + TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); + result = TCL_ERROR; Tcl_DecrRefCount(incrPtr); - goto gotError; + goto checkForCatch; } - cleanup = ((part2Ptr == NULL)? 1 : 2); - goto doIncrVar; case INST_INCR_ARRAY1_IMM: opnd = TclGetUInt1AtPtr(pc+1); - increment = TclGetInt1AtPtr(pc+2); - TclNewIntObj(incrPtr, increment); + i = TclGetInt1AtPtr(pc+2); + incrPtr = Tcl_NewIntObj(i); Tcl_IncrRefCount(incrPtr); pcAdjustment = 3; doIncrArray: part1Ptr = NULL; part2Ptr = OBJ_AT_TOS; - arrayPtr = LOCAL(opnd); + arrayPtr = &(compiledLocals[opnd]); cleanup = 1; while (TclIsVarLink(arrayPtr)) { arrayPtr = arrayPtr->value.linkPtr; } - TRACE(("%u \"%.30s\" (by %ld) => ", opnd, O2S(part2Ptr), increment)); + TRACE(("%u \"%.30s\" (by %ld) => ", opnd, O2S(part2Ptr), i)); varPtr = TclLookupArrayElement(interp, part1Ptr, part2Ptr, TCL_LEAVE_ERR_MSG, "read", 1, 1, arrayPtr, opnd); - if (!varPtr) { - TRACE_ERROR(interp); + if (varPtr) { + goto doIncrVar; + } else { + TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); + result = TCL_ERROR; Tcl_DecrRefCount(incrPtr); - goto gotError; + goto checkForCatch; } - 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); + varPtr = &(compiledLocals[opnd]); while (TclIsVarLink(varPtr)) { varPtr = varPtr->value.linkPtr; } if (TclIsVarDirectModifyable(varPtr)) { - void *ptr; + ClientData ptr; int type; objPtr = varPtr->value.objPtr; if (GetNumberFromObj(NULL, objPtr, &ptr, &type) == TCL_OK) { - if (type == TCL_NUMBER_INT) { - Tcl_WideInt augend = *((const Tcl_WideInt *)ptr); - Tcl_WideInt sum = (Tcl_WideInt)((Tcl_WideUInt)augend + (Tcl_WideUInt)increment); + if (type == TCL_NUMBER_LONG) { + long augend = *((const long *)ptr); + long sum = augend + i; /* * Overflow when (augend and sum have different sign) and - * (augend and increment have the same sign). This is - * encapsulated in the Overflowing macro. + * (augend and i have the same sign). This is encapsulated + * in the Overflowing macro. */ - if (!Overflowing(augend, increment, sum)) { - TRACE(("%u %ld => ", opnd, increment)); + if (!Overflowing(augend, i, sum)) { + TRACE(("%u %ld => ", opnd, i)); if (Tcl_IsShared(objPtr)) { objPtr->refCount--; /* We know it's shared. */ - TclNewIntObj(objResultPtr, sum); + TclNewLongObj(objResultPtr, sum); Tcl_IncrRefCount(objResultPtr); varPtr->value.objPtr = objResultPtr; } else { objResultPtr = objPtr; - TclSetIntObj(objPtr, sum); + TclSetLongObj(objPtr, sum); } goto doneIncr; } - w = (Tcl_WideInt)augend; - - TRACE(("%u %ld => ", opnd, increment)); - if (Tcl_IsShared(objPtr)) { - objPtr->refCount--; /* We know it's shared. */ - TclNewIntObj(objResultPtr, w + increment); - Tcl_IncrRefCount(objResultPtr); - varPtr->value.objPtr = objResultPtr; - } else { - objResultPtr = objPtr; +#ifndef NO_WIDE_TYPE + { + w = (Tcl_WideInt)augend; - /* - * We know the sum value is outside the Tcl_WideInt range; - * use macro form that doesn't range test again. - */ + TRACE(("%u %ld => ", opnd, i)); + if (Tcl_IsShared(objPtr)) { + objPtr->refCount--; /* We know it's shared. */ + objResultPtr = Tcl_NewWideIntObj(w+i); + Tcl_IncrRefCount(objResultPtr); + varPtr->value.objPtr = objResultPtr; + } else { + objResultPtr = objPtr; - TclSetIntObj(objPtr, w+increment); + /* + * We know the sum value is outside the long + * range; use macro form that doesn't range test + * again. + */ + + TclSetWideIntObj(objPtr, w+i); + } + goto doneIncr; } - goto doneIncr; - } /* end if (type == TCL_NUMBER_INT) */ +#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 + i; + + /* + * Check for overflow. + */ + + if (!Overflowing(w, i, sum)) { + TRACE(("%u %ld => ", opnd, i)); + 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 */ @@ -3761,32 +3261,34 @@ TEBCresume( } else { objResultPtr = objPtr; } - TclNewIntObj(incrPtr, increment); - if (TclIncrObj(interp, objResultPtr, incrPtr) != TCL_OK) { - Tcl_DecrRefCount(incrPtr); - TRACE_ERROR(interp); - goto gotError; - } + TclNewLongObj(incrPtr, i); + result = TclIncrObj(interp, objResultPtr, incrPtr); Tcl_DecrRefCount(incrPtr); - goto doneIncr; + if (result == TCL_OK) { + goto doneIncr; + } else { + TRACE_APPEND(("ERROR: %.30s\n", + O2S(Tcl_GetObjResult(interp)))); + goto checkForCatch; + } } /* * All other cases, flow through to generic handling. */ - TclNewIntObj(incrPtr, increment); + TclNewLongObj(incrPtr, i); Tcl_IncrRefCount(incrPtr); doIncrScalar: - varPtr = LOCAL(opnd); + varPtr = &(compiledLocals[opnd]); while (TclIsVarLink(varPtr)) { varPtr = varPtr->value.linkPtr; } arrayPtr = NULL; part1Ptr = part2Ptr = NULL; cleanup = 0; - TRACE(("%u %s => ", opnd, TclGetString(incrPtr))); + TRACE(("%u %ld => ", opnd, i)); doIncrVar: if (TclIsVarDirectModifyable2(varPtr, arrayPtr)) { @@ -3799,21 +3301,26 @@ TEBCresume( } else { objResultPtr = objPtr; } - if (TclIncrObj(interp, objResultPtr, incrPtr) != TCL_OK) { - Tcl_DecrRefCount(incrPtr); - TRACE_ERROR(interp); - goto gotError; - } + result = TclIncrObj(interp, objResultPtr, incrPtr); Tcl_DecrRefCount(incrPtr); + if (result == TCL_OK) { + goto doneIncr; + } else { + TRACE_APPEND(("ERROR: %.30s\n", + O2S(Tcl_GetObjResult(interp)))); + goto checkForCatch; + } } else { DECACHE_STACK_INFO(); - objResultPtr = TclPtrIncrObjVarIdx(interp, varPtr, arrayPtr, + objResultPtr = TclPtrIncrObjVar(interp, varPtr, arrayPtr, part1Ptr, part2Ptr, incrPtr, TCL_LEAVE_ERR_MSG, opnd); CACHE_STACK_INFO(); Tcl_DecrRefCount(incrPtr); if (objResultPtr == NULL) { - TRACE_ERROR(interp); - goto gotError; + TRACE_APPEND(("ERROR: %.30s\n", + O2S(Tcl_GetObjResult(interp)))); + result = TCL_ERROR; + goto checkForCatch; } } doneIncr: @@ -3828,15 +3335,21 @@ TEBCresume( /* * End of INST_INCR instructions. - * ----------------------------------------------------------------- + * --------------------------------------------------------- + */ + + /* + * --------------------------------------------------------- * Start of INST_EXIST instructions. */ + { + Tcl_Obj *part1Ptr, *part2Ptr; + Var *varPtr, *arrayPtr; - case INST_EXIST_SCALAR: - cleanup = 0; - pcAdjustment = 5; - opnd = TclGetUInt4AtPtr(pc+1); - varPtr = LOCAL(opnd); + case INST_EXIST_SCALAR: { + int opnd = TclGetUInt4AtPtr(pc+1); + + varPtr = &(compiledLocals[opnd]); while (TclIsVarLink(varPtr)) { varPtr = varPtr->value.linkPtr; } @@ -3851,14 +3364,21 @@ TEBCresume( varPtr = NULL; } } - goto afterExistsPeephole; - case INST_EXIST_ARRAY: - cleanup = 1; - pcAdjustment = 5; - opnd = TclGetUInt4AtPtr(pc+1); + /* + * Tricky! Arrays always exist. + */ + + objResultPtr = constants[!varPtr || TclIsVarUndefined(varPtr) ? 0 : 1]; + TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); + NEXT_INST_F(5, 0, 1); + } + + case INST_EXIST_ARRAY: { + int opnd = TclGetUInt4AtPtr(pc+1); + part2Ptr = OBJ_AT_TOS; - arrayPtr = LOCAL(opnd); + arrayPtr = &(compiledLocals[opnd]); while (TclIsVarLink(arrayPtr)) { arrayPtr = arrayPtr->value.linkPtr; } @@ -3866,7 +3386,7 @@ TEBCresume( if (TclIsVarArray(arrayPtr) && !ReadTraced(arrayPtr)) { varPtr = VarHashFindVar(arrayPtr->value.tablePtr, part2Ptr); if (!varPtr || !ReadTraced(varPtr)) { - goto afterExistsPeephole; + goto doneExistArray; } } varPtr = TclLookupArrayElement(interp, NULL, part2Ptr, 0, "access", @@ -3883,11 +3403,14 @@ TEBCresume( varPtr = NULL; } } - goto afterExistsPeephole; + doneExistArray: + objResultPtr = constants[!varPtr || TclIsVarUndefined(varPtr) ? 0 : 1]; + TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); + NEXT_INST_F(5, 1, 1); + } case INST_EXIST_ARRAY_STK: cleanup = 2; - pcAdjustment = 1; part2Ptr = OBJ_AT_TOS; /* element name */ part1Ptr = OBJ_UNDER_TOS; /* array name */ TRACE(("\"%.30s(%.30s)\" => ", O2S(part1Ptr), O2S(part2Ptr))); @@ -3895,7 +3418,6 @@ TEBCresume( case INST_EXIST_STK: cleanup = 1; - pcAdjustment = 1; part2Ptr = NULL; part1Ptr = OBJ_AT_TOS; /* variable name */ TRACE(("\"%.30s\" => ", O2S(part1Ptr))); @@ -3915,337 +3437,89 @@ TEBCresume( varPtr = NULL; } } - - /* - * Peep-hole optimisation: if you're about to jump, do jump from here. - */ - - afterExistsPeephole: { - int found = (varPtr && !TclIsVarUndefined(varPtr)); - - TRACE_APPEND(("%d\n", found ? 1 : 0)); - JUMP_PEEPHOLE_V(found, pcAdjustment, cleanup); + objResultPtr = constants[!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 => ", (flags ? "normal" : "noerr"), opnd)); - if (TclIsVarDirectUnsettable(varPtr) && !TclIsVarInHash(varPtr)) { - /* - * No errors, no traces, no searches: just make the variable cease - * to exist. - */ + case INST_UPVAR: { + int opnd; + Var *varPtr, *otherPtr; - if (!TclIsVarUndefined(varPtr)) { - TclDecrRefCount(varPtr->value.objPtr); - } else if (flags & TCL_LEAVE_ERR_MSG) { - goto slowUnsetScalar; - } - varPtr->value.objPtr = NULL; - TRACE_APPEND(("OK\n")); - NEXT_INST_F(6, 0, 0); - } + TRACE_WITH_OBJ(("upvar "), OBJ_UNDER_TOS); - slowUnsetScalar: - DECACHE_STACK_INFO(); - if (TclPtrUnsetVarIdx(interp, varPtr, NULL, NULL, NULL, flags, - opnd) != TCL_OK && flags) { - goto errorInUnset; - } - CACHE_STACK_INFO(); - NEXT_INST_F(6, 0, 0); + { + CallFrame *framePtr, *savedFramePtr; - 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\" => ", - (flags ? "normal" : "noerr"), opnd, O2S(part2Ptr))); - if (TclIsVarArray(arrayPtr) && !UnsetTraced(arrayPtr) - && !(arrayPtr->flags & VAR_SEARCH_ACTIVE)) { - varPtr = VarHashFindVar(arrayPtr->value.tablePtr, part2Ptr); - if (varPtr && TclIsVarDirectUnsettable(varPtr)) { + result = TclObjGetFrame(interp, OBJ_UNDER_TOS, &framePtr); + if (result != -1) { /* - * No nasty traces and element exists, so we can proceed to - * unset it. Might still not exist though... + * Locate the other variable. */ - if (!TclIsVarUndefined(varPtr)) { - TclDecrRefCount(varPtr->value.objPtr); - TclSetVarUndefined(varPtr); - TclClearVarNamespaceVar(varPtr); - TclCleanupVar(varPtr, arrayPtr); - } else if (flags & TCL_LEAVE_ERR_MSG) { - goto slowUnsetArray; + 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) { + result = TCL_OK; + goto doLinkVars; } - TRACE_APPEND(("OK\n")); - NEXT_INST_F(6, 1, 0); - } else if (!varPtr && !(flags & TCL_LEAVE_ERR_MSG)) { - /* - * Don't need to do anything here. - */ - - TRACE_APPEND(("OK\n")); - NEXT_INST_F(6, 1, 0); } + result = TCL_ERROR; + goto checkForCatch; } - 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 (TclPtrUnsetVarIdx(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)\" => ", (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\" => ", (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(); - TRACE_APPEND(("OK\n")); - NEXT_INST_V(2, cleanup, 0); - errorInUnset: - CACHE_STACK_INFO(); - TRACE_ERROR(interp); - goto gotError; - - /* - * This is really an unset operation these days. Do not issue. - */ + 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) { + /* + * Do the [variable] magic. + */ - case INST_DICT_DONE: - opnd = TclGetUInt4AtPtr(pc+1); - TRACE(("%u => OK\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(); - TclPtrUnsetVarIdx(interp, varPtr, NULL, NULL, NULL, 0, opnd); - CACHE_STACK_INFO(); + TclSetVarNamespaceVar(otherPtr); + result = TCL_OK; + goto doLinkVars; } - NEXT_INST_F(5, 0, 0); - } - break; + result = TCL_ERROR; + goto checkForCatch; - /* - * End of INST_UNSET instructions. - * ----------------------------------------------------------------- - * Start of INST_ARRAY instructions. - */ + case INST_NSUPVAR: + TRACE_WITH_OBJ(("nsupvar "), OBJ_UNDER_TOS); - case INST_ARRAY_EXISTS_IMM: - opnd = TclGetUInt4AtPtr(pc+1); - pcAdjustment = 5; - cleanup = 0; - part1Ptr = NULL; - arrayPtr = NULL; - TRACE(("%u => ", opnd)); - varPtr = LOCAL(opnd); - while (TclIsVarLink(varPtr)) { - varPtr = varPtr->value.linkPtr; - } - goto doArrayExists; - case INST_ARRAY_EXISTS_STK: - opnd = -1; - pcAdjustment = 1; - cleanup = 1; - part1Ptr = OBJ_AT_TOS; - TRACE(("\"%.30s\" => ", O2S(part1Ptr))); - varPtr = TclObjLookupVarEx(interp, part1Ptr, NULL, 0, NULL, - /*createPart1*/0, /*createPart2*/0, &arrayPtr); - doArrayExists: - DECACHE_STACK_INFO(); - result = TclCheckArrayTraces(interp, varPtr, arrayPtr, part1Ptr, opnd); - CACHE_STACK_INFO(); - if (result == TCL_ERROR) { - TRACE_ERROR(interp); - goto gotError; - } - if (varPtr && TclIsVarArray(varPtr) && !TclIsVarUndefined(varPtr)) { - objResultPtr = TCONST(1); - } else { - objResultPtr = TCONST(0); - } - TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); - NEXT_INST_V(pcAdjustment, cleanup, 1); + { + Tcl_Namespace *nsPtr, *savedNsPtr; - case INST_ARRAY_MAKE_IMM: - opnd = TclGetUInt4AtPtr(pc+1); - pcAdjustment = 5; - cleanup = 0; - part1Ptr = NULL; - arrayPtr = NULL; - TRACE(("%u => ", opnd)); - varPtr = LOCAL(opnd); - while (TclIsVarLink(varPtr)) { - varPtr = varPtr->value.linkPtr; - } - goto doArrayMake; - case INST_ARRAY_MAKE_STK: - opnd = -1; - pcAdjustment = 1; - cleanup = 1; - part1Ptr = OBJ_AT_TOS; - TRACE(("\"%.30s\" => ", O2S(part1Ptr))); - varPtr = TclObjLookupVarEx(interp, part1Ptr, NULL, TCL_LEAVE_ERR_MSG, - "set", /*createPart1*/1, /*createPart2*/0, &arrayPtr); - if (varPtr == NULL) { - TRACE_ERROR(interp); - goto gotError; - } - doArrayMake: - if (varPtr && !TclIsVarArray(varPtr)) { - if (TclIsVarArrayElement(varPtr) || !TclIsVarUndefined(varPtr)) { + result = TclGetNamespaceFromObj(interp, OBJ_UNDER_TOS, &nsPtr); + if (result == TCL_OK) { /* - * Either an array element, or a scalar: lose! + * Locate the other variable. */ - TclObjVarErrMsg(interp, part1Ptr, NULL, "array set", - "variable isn't array", opnd); - DECACHE_STACK_INFO(); - Tcl_SetErrorCode(interp, "TCL", "WRITE", "ARRAY", (void *)NULL); - CACHE_STACK_INFO(); - TRACE_ERROR(interp); - goto gotError; + savedNsPtr = (Tcl_Namespace *) 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 = (Namespace *) savedNsPtr; + if (otherPtr) { + goto doLinkVars; + } } - TclInitArrayVar(varPtr); -#ifdef TCL_COMPILE_DEBUG - TRACE_APPEND(("done\n")); - } else { - TRACE_APPEND(("nothing to do\n")); -#endif - } - NEXT_INST_V(pcAdjustment, cleanup, 0); - - /* - * End of INST_ARRAY instructions. - * ----------------------------------------------------------------- - * Start of variable linking instructions. - */ - - { - Var *otherPtr; - CallFrame *framePtr, *savedFramePtr; - Tcl_Namespace *nsPtr; - Namespace *savedNsPtr; - - case INST_UPVAR: - TRACE(("%d %.30s %.30s => ", TclGetInt4AtPtr(pc+1), - O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS))); - - if (TclObjGetFrame(interp, OBJ_UNDER_TOS, &framePtr) == -1) { - TRACE_ERROR(interp); - 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) { - TRACE_ERROR(interp); - goto gotError; - } - goto doLinkVars; - - case INST_NSUPVAR: - TRACE(("%d %.30s %.30s => ", TclGetInt4AtPtr(pc+1), - O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS))); - if (TclGetNamespaceFromObj(interp, OBJ_UNDER_TOS, &nsPtr) != TCL_OK) { - TRACE_ERROR(interp); - 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|TCL_AVOID_RESOLVERS), - "access", /*createPart1*/ 1, /*createPart2*/ 1, &varPtr); - iPtr->varFramePtr->nsPtr = savedNsPtr; - if (!otherPtr) { - TRACE_ERROR(interp); - goto gotError; - } - goto doLinkVars; - - case INST_VARIABLE: - TRACE(("%d, %.30s => ", TclGetInt4AtPtr(pc+1), O2S(OBJ_AT_TOS))); - otherPtr = TclObjLookupVarEx(interp, OBJ_AT_TOS, NULL, - (TCL_NAMESPACE_ONLY | TCL_LEAVE_ERR_MSG), "access", - /*createPart1*/ 1, /*createPart2*/ 1, &varPtr); - if (!otherPtr) { - TRACE_ERROR(interp); - goto gotError; + result = TCL_ERROR; + goto checkForCatch; } - /* - * Do the [variable] magic. - */ - - TclSetVarNamespaceVar(otherPtr); - doLinkVars: /* @@ -4254,8 +3528,8 @@ TEBCresume( * if there are no errors; otherwise, let it handle the case. */ - opnd = TclGetInt4AtPtr(pc+1); - varPtr = LOCAL(opnd); + opnd = TclGetInt4AtPtr(pc+1);; + varPtr = &(compiledLocals[opnd]); if ((varPtr != otherPtr) && !TclIsVarTraced(varPtr) && (TclIsVarUndefined(varPtr) || TclIsVarLink(varPtr))) { if (!TclIsVarUndefined(varPtr)) { @@ -4266,8 +3540,7 @@ TEBCresume( Var *linkPtr = varPtr->value.linkPtr; if (linkPtr == otherPtr) { - TRACE_APPEND(("already linked\n")); - NEXT_INST_F(5, 1, 0); + goto doLinkVarsDone; } if (TclIsVarInHash(linkPtr)) { VarHashRefCount(linkPtr)--; @@ -4281,10 +3554,11 @@ TEBCresume( if (TclIsVarInHash(otherPtr)) { VarHashRefCount(otherPtr)++; } - } else if (TclPtrObjMakeUpvarIdx(interp, otherPtr, NULL, 0, - opnd) != TCL_OK) { - TRACE_ERROR(interp); - goto gotError; + } else { + result = TclPtrObjMakeUpvar(interp, otherPtr, NULL, 0, opnd); + if (result != TCL_OK) { + goto checkForCatch; + } } /* @@ -4292,37 +3566,35 @@ TEBCresume( * variables - and [variable] did not push it at all. */ - TRACE_APPEND(("link made\n")); + doLinkVarsDone: NEXT_INST_F(5, 1, 0); } - break; - /* - * End of variable linking instructions. - * ----------------------------------------------------------------- - */ + case INST_JUMP1: { + int opnd = TclGetInt1AtPtr(pc+1); - case INST_JUMP1: - opnd = TclGetInt1AtPtr(pc+1); - TRACE(("%d => new pc %" TCL_Z_MODIFIER "u\n", opnd, - (size_t)(pc + opnd - codePtr->codeStart))); + TRACE(("%d => new pc %u\n", opnd, + (unsigned)(pc + opnd - codePtr->codeStart))); NEXT_INST_F(opnd, 0, 0); - break; + } - case INST_JUMP4: - opnd = TclGetInt4AtPtr(pc+1); - TRACE(("%d => new pc %" TCL_Z_MODIFIER "u\n", opnd, - (size_t)(pc + opnd - codePtr->codeStart))); + case INST_JUMP4: { + int opnd = TclGetInt4AtPtr(pc+1); + + TRACE(("%d => new pc %u\n", opnd, + (unsigned)(pc + opnd - codePtr->codeStart))); NEXT_INST_F(opnd, 0, 0); + } { int jmpOffset[2], b; + Tcl_Obj *valuePtr; /* 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 */ + jmpOffset[1] = 5; /* TRUE offset*/ goto doCondJump; case INST_JUMP_TRUE4: @@ -4341,40 +3613,43 @@ TEBCresume( doCondJump: valuePtr = OBJ_AT_TOS; - TRACE(("%d => ", jmpOffset[ - (*pc==INST_JUMP_FALSE1 || *pc==INST_JUMP_FALSE4) ? 0 : 1])); /* TODO - check claim that taking address of b harms performance */ /* TODO - consider optimization search for constants */ - if (TclGetBooleanFromObj(interp, valuePtr, &b) != TCL_OK) { - TRACE_ERROR(interp); - goto gotError; + result = TclGetBooleanFromObj(interp, valuePtr, &b); + if (result != TCL_OK) { + TRACE_WITH_OBJ(("%d => ERROR: ", jmpOffset[ + ((*pc == INST_JUMP_FALSE1) || (*pc == INST_JUMP_FALSE4)) + ? 0 : 1]), Tcl_GetObjResult(interp)); + goto checkForCatch; } #ifdef TCL_COMPILE_DEBUG if (b) { if ((*pc == INST_JUMP_TRUE1) || (*pc == INST_JUMP_TRUE4)) { - TRACE_APPEND(("%.20s true, new pc %" TCL_Z_MODIFIER "u\n", O2S(valuePtr), - (size_t)(pc + jmpOffset[1] - codePtr->codeStart))); + TRACE(("%d => %.20s true, new pc %u\n", jmpOffset[1], + O2S(valuePtr), + (unsigned)(pc + jmpOffset[1] - codePtr->codeStart))); } else { - TRACE_APPEND(("%.20s true\n", O2S(valuePtr))); + TRACE(("%d => %.20s true\n", jmpOffset[0], O2S(valuePtr))); } } else { if ((*pc == INST_JUMP_TRUE1) || (*pc == INST_JUMP_TRUE4)) { - TRACE_APPEND(("%.20s false\n", O2S(valuePtr))); + TRACE(("%d => %.20s false\n", jmpOffset[0], O2S(valuePtr))); } else { - TRACE_APPEND(("%.20s false, new pc %" TCL_Z_MODIFIER "u\n", O2S(valuePtr), - (size_t)(pc + jmpOffset[0] - codePtr->codeStart))); + TRACE(("%d => %.20s false, new pc %u\n", jmpOffset[0], + O2S(valuePtr), + (unsigned)(pc + jmpOffset[1] - codePtr->codeStart))); } } #endif NEXT_INST_F(jmpOffset[b], 1, 0); } - break; case INST_JUMP_TABLE: { Tcl_HashEntry *hPtr; JumptableInfo *jtPtr; + int opnd; /* * Jump to location looked up in a hashtable; fall through to next @@ -4383,20 +3658,19 @@ TEBCresume( opnd = TclGetInt4AtPtr(pc+1); jtPtr = (JumptableInfo *) codePtr->auxDataArrayPtr[opnd].clientData; - TRACE(("%d \"%.20s\" => ", opnd, O2S(OBJ_AT_TOS))); + 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 %" TCL_Z_MODIFIER "u\n", - (size_t)(pc - codePtr->codeStart + jumpOffset))); + 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); } } - break; /* * These two instructions are now redundant: the complete logic of the LOR @@ -4411,25 +3685,27 @@ TEBCresume( */ int i1, i2, iResult; + Tcl_Obj *value2Ptr = OBJ_AT_TOS; + Tcl_Obj *valuePtr = OBJ_UNDER_TOS; - value2Ptr = OBJ_AT_TOS; - valuePtr = OBJ_UNDER_TOS; - if (TclGetBooleanFromObj(NULL, valuePtr, &i1) != TCL_OK) { + result = TclGetBooleanFromObj(NULL, valuePtr, &i1); + if (result != 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; + goto checkForCatch; } - if (TclGetBooleanFromObj(NULL, value2Ptr, &i2) != TCL_OK) { + result = TclGetBooleanFromObj(NULL, value2Ptr, &i2); + if (result != 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; + goto checkForCatch; } if (*pc == INST_LOR) { @@ -4437,486 +3713,98 @@ TEBCresume( } else { iResult = (i1 && i2); } - objResultPtr = TCONST(iResult); + objResultPtr = constants[iResult]; TRACE(("%.20s %.20s => %d\n", O2S(valuePtr),O2S(value2Ptr),iResult)); NEXT_INST_F(1, 2, 1); } - break; /* - * ----------------------------------------------------------------- - * Start of general introspector instructions. - */ - - case INST_NS_CURRENT: { - Namespace *currNsPtr = (Namespace *) TclGetCurrentNamespace(interp); - - if (currNsPtr == (Namespace *) TclGetGlobalNamespace(interp)) { - TclNewLiteralStringObj(objResultPtr, "::"); - } else { - TclNewStringObj(objResultPtr, currNsPtr->fullName, - strlen(currNsPtr->fullName)); - } - TRACE_WITH_OBJ(("=> "), objResultPtr); - NEXT_INST_F(1, 0, 1); - } - break; - case INST_COROUTINE_NAME: { - CoroutineData *corPtr = iPtr->execEnvPtr->corPtr; - - TclNewObj(objResultPtr); - if (corPtr && !(corPtr->cmdPtr->flags & CMD_DYING)) { - Tcl_GetCommandFullName(interp, (Tcl_Command) corPtr->cmdPtr, - objResultPtr); - } - TRACE_WITH_OBJ(("=> "), objResultPtr); - NEXT_INST_F(1, 0, 1); - } - break; - case INST_INFO_LEVEL_NUM: - TclNewIntObj(objResultPtr, iPtr->varFramePtr->level); - TRACE_WITH_OBJ(("=> "), objResultPtr); - NEXT_INST_F(1, 0, 1); - break; - case INST_INFO_LEVEL_ARGS: { - int level; - CallFrame *framePtr = iPtr->varFramePtr; - CallFrame *rootFramePtr = iPtr->rootFramePtr; - - TRACE(("\"%.30s\" => ", O2S(OBJ_AT_TOS))); - if (TclGetIntFromObj(interp, OBJ_AT_TOS, &level) != TCL_OK) { - TRACE_ERROR(interp); - goto gotError; - } - if (level <= 0) { - level += framePtr->level; - } - for (; (framePtr->level!=level) && (framePtr!=rootFramePtr) ; - framePtr = framePtr->callerVarPtr) { - /* Empty loop body */ - } - if (framePtr == rootFramePtr) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "bad level \"%s\"", TclGetString(OBJ_AT_TOS))); - TRACE_ERROR(interp); - DECACHE_STACK_INFO(); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "STACK_LEVEL", - TclGetString(OBJ_AT_TOS), (void *)NULL); - CACHE_STACK_INFO(); - goto gotError; - } - objResultPtr = Tcl_NewListObj(framePtr->objc, framePtr->objv); - TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); - NEXT_INST_F(1, 1, 1); - } - { - Tcl_Command cmd, origCmd; - - case INST_RESOLVE_COMMAND: - cmd = Tcl_GetCommandFromObj(interp, OBJ_AT_TOS); - TclNewObj(objResultPtr); - if (cmd != NULL) { - Tcl_GetCommandFullName(interp, cmd, objResultPtr); - } - TRACE_WITH_OBJ(("\"%.20s\" => ", O2S(OBJ_AT_TOS)), objResultPtr); - NEXT_INST_F(1, 1, 1); - - case INST_ORIGIN_COMMAND: - TRACE(("\"%.30s\" => ", O2S(OBJ_AT_TOS))); - cmd = Tcl_GetCommandFromObj(interp, OBJ_AT_TOS); - if (cmd == NULL) { - goto instOriginError; - } - origCmd = TclGetOriginalCommand(cmd); - if (origCmd == NULL) { - origCmd = cmd; - } - - TclNewObj(objResultPtr); - Tcl_GetCommandFullName(interp, origCmd, objResultPtr); - if (TclCheckEmptyString(objResultPtr) == TCL_EMPTYSTRING_YES ) { - Tcl_DecrRefCount(objResultPtr); - instOriginError: - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "invalid command name \"%s\"", TclGetString(OBJ_AT_TOS))); - DECACHE_STACK_INFO(); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COMMAND", - TclGetString(OBJ_AT_TOS), (void *)NULL); - CACHE_STACK_INFO(); - TRACE_APPEND(("ERROR: not command\n")); - goto gotError; - } - TRACE_APPEND(("\"%.30s\"", O2S(OBJ_AT_TOS))); - NEXT_INST_F(1, 1, 1); - } - - /* - * ----------------------------------------------------------------- - * Start of TclOO support instructions. + * --------------------------------------------------------- + * Start of INST_LIST and related instructions. */ - { - Object *oPtr; - CallFrame *framePtr; - CallContext *contextPtr; - Tcl_Size skip, newDepth; - - case INST_TCLOO_SELF: - framePtr = iPtr->varFramePtr; - if (framePtr == NULL || - !(framePtr->isProcCallFrame & FRAME_IS_METHOD)) { - TRACE(("=> ERROR: no TclOO call context\n")); - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "self may only be called from inside a method", - -1)); - DECACHE_STACK_INFO(); - Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", (void *)NULL); - CACHE_STACK_INFO(); - goto gotError; - } - contextPtr = (CallContext *)framePtr->clientData; - + case INST_LIST: { /* - * Call out to get the name; it's expensive to compute but cached. + * Pop the opnd (objc) top stack elements into a new list obj and then + * decrement their ref counts. */ - objResultPtr = TclOOObjectName(interp, contextPtr->oPtr); - TRACE_WITH_OBJ(("=> "), objResultPtr); - NEXT_INST_F(1, 0, 1); - - case INST_TCLOO_NEXT_CLASS: - opnd = TclGetUInt1AtPtr(pc+1); - framePtr = iPtr->varFramePtr; - valuePtr = OBJ_AT_DEPTH(opnd - 2); - objv = &OBJ_AT_DEPTH(opnd - 1); - skip = 2; - TRACE(("%d => ", opnd)); - if (framePtr == NULL || - !(framePtr->isProcCallFrame & FRAME_IS_METHOD)) { - TRACE_APPEND(("ERROR: no TclOO call context\n")); - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "nextto may only be called from inside a method", - -1)); - DECACHE_STACK_INFO(); - Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", (void *)NULL); - CACHE_STACK_INFO(); - goto gotError; - } - contextPtr = (CallContext *)framePtr->clientData; - - oPtr = (Object *) Tcl_GetObjectFromObj(interp, valuePtr); - if (oPtr == NULL) { - TRACE_APPEND(("ERROR: \"%.30s\" not object\n", O2S(valuePtr))); - goto gotError; - } else { - Class *classPtr = oPtr->classPtr; - struct MInvoke *miPtr; - Tcl_Size i; - const char *methodType; - - if (classPtr == NULL) { - TRACE_APPEND(("ERROR: \"%.30s\" not class\n", O2S(valuePtr))); - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "\"%s\" is not a class", TclGetString(valuePtr))); - DECACHE_STACK_INFO(); - Tcl_SetErrorCode(interp, "TCL", "OO", "CLASS_REQUIRED", (void *)NULL); - CACHE_STACK_INFO(); - goto gotError; - } - - for (i=contextPtr->index+1 ; i<contextPtr->callPtr->numChain ; i++) { - miPtr = contextPtr->callPtr->chain + i; - if (!miPtr->isFilter && - miPtr->mPtr->declaringClassPtr == classPtr) { - newDepth = i; -#ifdef TCL_COMPILE_DEBUG - if (tclTraceExec >= 2) { - if (traceInstructions) { - strncpy(cmdNameBuf, TclGetString(objv[0]), 20); - } else { - fprintf(stdout, "%" TCL_SIZE_MODIFIER "d: (%" TCL_T_MODIFIER "d) invoking ", - iPtr->numLevels, - (size_t)(pc - codePtr->codeStart)); - } - for (i = 0; i < opnd; i++) { - TclPrintObject(stdout, objv[i], 15); - fprintf(stdout, " "); - } - fprintf(stdout, "\n"); - fflush(stdout); - } -#endif /*TCL_COMPILE_DEBUG*/ - goto doInvokeNext; - } - } - - if (contextPtr->callPtr->flags & CONSTRUCTOR) { - methodType = "constructor"; - } else if (contextPtr->callPtr->flags & DESTRUCTOR) { - methodType = "destructor"; - } else { - methodType = "method"; - } + int opnd; - TRACE_APPEND(("ERROR: \"%.30s\" not on reachable chain\n", - O2S(valuePtr))); - for (i = contextPtr->index ; i != TCL_INDEX_NONE ; i--) { - miPtr = contextPtr->callPtr->chain + i; - if (miPtr->isFilter - || miPtr->mPtr->declaringClassPtr != classPtr) { - continue; - } - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "%s implementation by \"%s\" not reachable from here", - methodType, TclGetString(valuePtr))); - DECACHE_STACK_INFO(); - Tcl_SetErrorCode(interp, "TCL", "OO", "CLASS_NOT_REACHABLE", - (void *)NULL); - CACHE_STACK_INFO(); - goto gotError; - } - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "%s has no non-filter implementation by \"%s\"", - methodType, TclGetString(valuePtr))); - DECACHE_STACK_INFO(); - Tcl_SetErrorCode(interp, "TCL", "OO", "CLASS_NOT_THERE", (void *)NULL); - CACHE_STACK_INFO(); - goto gotError; - } - - case INST_TCLOO_NEXT: - opnd = TclGetUInt1AtPtr(pc+1); - objv = &OBJ_AT_DEPTH(opnd - 1); - framePtr = iPtr->varFramePtr; - skip = 1; - TRACE(("%d => ", opnd)); - if (framePtr == NULL || - !(framePtr->isProcCallFrame & FRAME_IS_METHOD)) { - TRACE_APPEND(("ERROR: no TclOO call context\n")); - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "next may only be called from inside a method", - -1)); - DECACHE_STACK_INFO(); - Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", (void *)NULL); - CACHE_STACK_INFO(); - goto gotError; - } - contextPtr = (CallContext *)framePtr->clientData; - - newDepth = contextPtr->index + 1; - if (newDepth >= contextPtr->callPtr->numChain) { - /* - * We're at the end of the chain; generate an error message unless - * the interpreter is being torn down, in which case we might be - * getting here because of methods/destructors doing a [next] (or - * equivalent) unexpectedly. - */ - - const char *methodType; - - if (contextPtr->callPtr->flags & CONSTRUCTOR) { - methodType = "constructor"; - } else if (contextPtr->callPtr->flags & DESTRUCTOR) { - methodType = "destructor"; - } else { - methodType = "method"; - } - - TRACE_APPEND(("ERROR: no TclOO next impl\n")); - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "no next %s implementation", methodType)); - DECACHE_STACK_INFO(); - Tcl_SetErrorCode(interp, "TCL", "OO", "NOTHING_NEXT", (void *)NULL); - CACHE_STACK_INFO(); - goto gotError; -#ifdef TCL_COMPILE_DEBUG - } else if (tclTraceExec >= 2) { - int i; - - if (traceInstructions) { - strncpy(cmdNameBuf, TclGetString(objv[0]), 20); - } else { - fprintf(stdout, "%" TCL_SIZE_MODIFIER "d: (%" TCL_Z_MODIFIER "u) invoking ", - iPtr->numLevels, (size_t)(pc - codePtr->codeStart)); - } - for (i = 0; i < opnd; i++) { - TclPrintObject(stdout, objv[i], 15); - fprintf(stdout, " "); - } - fprintf(stdout, "\n"); - fflush(stdout); -#endif /*TCL_COMPILE_DEBUG*/ - } + opnd = TclGetUInt4AtPtr(pc+1); + objResultPtr = Tcl_NewListObj(opnd, &OBJ_AT_DEPTH(opnd-1)); + TRACE_WITH_OBJ(("%u => ", opnd), objResultPtr); + NEXT_INST_V(5, opnd, 1); + } - doInvokeNext: - bcFramePtr->data.tebc.pc = (char *) pc; - iPtr->cmdFramePtr = bcFramePtr; + case INST_LIST_LENGTH: { + Tcl_Obj *valuePtr; + int length; - if (iPtr->flags & INTERP_DEBUG_FRAME) { - ArgumentBCEnter(interp, codePtr, TD, pc, opnd, objv); - } + valuePtr = OBJ_AT_TOS; - pcAdjustment = 2; - cleanup = opnd; - DECACHE_STACK_INFO(); - iPtr->varFramePtr = framePtr->callerVarPtr; - pc += pcAdjustment; - TEBC_YIELD(); - - TclPushTailcallPoint(interp); - oPtr = contextPtr->oPtr; - if (oPtr->flags & FILTER_HANDLING) { - TclNRAddCallback(interp, FinalizeOONextFilter, - framePtr, contextPtr, INT2PTR(contextPtr->index), - INT2PTR(contextPtr->skip)); - } else { - TclNRAddCallback(interp, FinalizeOONext, - framePtr, contextPtr, INT2PTR(contextPtr->index), - INT2PTR(contextPtr->skip)); - } - contextPtr->skip = skip; - contextPtr->index = newDepth; - if (contextPtr->callPtr->chain[newDepth].isFilter - || contextPtr->callPtr->flags & FILTER_HANDLING) { - oPtr->flags |= FILTER_HANDLING; + result = TclListObjLength(interp, valuePtr, &length); + if (result == TCL_OK) { + TclNewIntObj(objResultPtr, length); + TRACE(("%.20s => %d\n", O2S(valuePtr), length)); + NEXT_INST_F(1, 1, 1); } else { - oPtr->flags &= ~FILTER_HANDLING; - } - - { - Method *const mPtr = - contextPtr->callPtr->chain[newDepth].mPtr; - - return mPtr->typePtr->callProc(mPtr->clientData, interp, - (Tcl_ObjectContext) contextPtr, opnd, objv); - } - - case INST_TCLOO_IS_OBJECT: - oPtr = (Object *) Tcl_GetObjectFromObj(interp, OBJ_AT_TOS); - objResultPtr = TCONST(oPtr != NULL ? 1 : 0); - TRACE_WITH_OBJ(("%.30s => ", O2S(OBJ_AT_TOS)), objResultPtr); - NEXT_INST_F(1, 1, 1); - case INST_TCLOO_CLASS: - oPtr = (Object *) Tcl_GetObjectFromObj(interp, OBJ_AT_TOS); - if (oPtr == NULL) { - TRACE(("%.30s => ERROR: not object\n", O2S(OBJ_AT_TOS))); - goto gotError; - } - objResultPtr = TclOOObjectName(interp, oPtr->selfCls->thisPtr); - TRACE_WITH_OBJ(("%.30s => ", O2S(OBJ_AT_TOS)), objResultPtr); - NEXT_INST_F(1, 1, 1); - case INST_TCLOO_NS: - oPtr = (Object *) Tcl_GetObjectFromObj(interp, OBJ_AT_TOS); - if (oPtr == NULL) { - TRACE(("%.30s => ERROR: not object\n", O2S(OBJ_AT_TOS))); - goto gotError; + TRACE_WITH_OBJ(("%.30s => ERROR: ", O2S(valuePtr)), + Tcl_GetObjResult(interp)); + goto checkForCatch; } - - /* - * TclOO objects *never* have the global namespace as their NS. - */ - - TclNewStringObj(objResultPtr, oPtr->namespacePtr->fullName, - strlen(oPtr->namespacePtr->fullName)); - TRACE_WITH_OBJ(("%.30s => ", O2S(OBJ_AT_TOS)), objResultPtr); - NEXT_INST_F(1, 1, 1); } - /* - * End of TclOO support instructions. - * ----------------------------------------------------------------- - * Start of INST_LIST and related instructions. - */ + case INST_LIST_INDEX: { + /*** lindex with objc == 3 ***/ - { - int numIndices, nocase, match, cflags; - Tcl_Size length2, fromIdx, toIdx, index, s1len, s2len; - const char *s1, *s2; + /* Variables also for INST_LIST_INDEX_IMM */ + + int listc, idx, opnd, pcAdjustment; + Tcl_Obj **listv; + Tcl_Obj *valuePtr, *value2Ptr; - case INST_LIST: /* - * Pop the opnd (objc) top stack elements into a new list obj and then - * decrement their ref counts. + * Pop the two operands. */ - opnd = TclGetUInt4AtPtr(pc+1); - objResultPtr = Tcl_NewListObj(opnd, &OBJ_AT_DEPTH(opnd-1)); - TRACE_WITH_OBJ(("%u => ", opnd), objResultPtr); - NEXT_INST_V(5, opnd, 1); - - case INST_LIST_LENGTH: - TRACE(("\"%.30s\" => ", O2S(OBJ_AT_TOS))); - if (TclListObjLength(interp, OBJ_AT_TOS, &length) != TCL_OK) { - TRACE_ERROR(interp); - goto gotError; - } - TclNewIntObj(objResultPtr, length); - TRACE_APPEND(("%" TCL_SIZE_MODIFIER "d\n", length)); - NEXT_INST_F(1, 1, 1); - - case INST_LIST_INDEX: /* lindex with objc == 3 */ value2Ptr = OBJ_AT_TOS; valuePtr = OBJ_UNDER_TOS; - TRACE(("\"%.30s\" \"%.30s\" => ", O2S(valuePtr), O2S(value2Ptr))); - - - /* special case for ArithSeries */ - if (TclHasInternalRep(valuePtr,&tclArithSeriesType)) { - length = TclArithSeriesObjLength(valuePtr); - if (TclGetIntForIndexM(interp, value2Ptr, length-1, &index)!=TCL_OK) { - CACHE_STACK_INFO(); - TRACE_ERROR(interp); - goto gotError; - } - objResultPtr = TclArithSeriesObjIndex(interp, valuePtr, index); - if (objResultPtr == NULL) { - CACHE_STACK_INFO(); - TRACE_ERROR(interp); - goto gotError; - } - Tcl_IncrRefCount(objResultPtr); // reference held here - goto lindexDone; - } /* * Extract the desired list element. */ - if ((TclListObjGetElements(interp, valuePtr, &objc, &objv) == TCL_OK) - && !TclHasInternalRep(value2Ptr, &tclListType)) { - int code; - - DECACHE_STACK_INFO(); - code = TclGetIntForIndexM(interp, value2Ptr, objc-1, &index); - CACHE_STACK_INFO(); - if (code == TCL_OK) { - TclDecrRefCount(value2Ptr); - tosPtr--; - pcAdjustment = 1; - goto lindexFastPath; - } - Tcl_ResetResult(interp); + result = TclListObjGetElements(interp, valuePtr, &listc, &listv); + if ((result == TCL_OK) && (value2Ptr->typePtr != &tclListType) + && (TclGetIntForIndexM(NULL , value2Ptr, listc-1, + &idx) == TCL_OK)) { + TclDecrRefCount(value2Ptr); + tosPtr--; + pcAdjustment = 1; + goto lindexFastPath; } - DECACHE_STACK_INFO(); objResultPtr = TclLindexList(interp, valuePtr, value2Ptr); - CACHE_STACK_INFO(); + if (objResultPtr) { + /* + * Stash the list element on the stack. + */ - lindexDone: - if (!objResultPtr) { - TRACE_ERROR(interp); - goto gotError; + TRACE(("%.20s %.20s => %s\n", + O2S(valuePtr), O2S(value2Ptr), O2S(objResultPtr))); + NEXT_INST_F(1, 2, -1); /* Already has the correct refCount */ + } else { + TRACE_WITH_OBJ(("%.30s %.30s => ERROR: ", O2S(valuePtr), + O2S(value2Ptr)), Tcl_GetObjResult(interp)); + result = TCL_ERROR; + goto checkForCatch; } - /* - * Stash the list element on the stack. - */ + case INST_LIST_INDEX_IMM: + /*** lindex with objc==3 and index in bytecode stream ***/ - TRACE_APPEND(("\"%.30s\"\n", 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 */ + pcAdjustment = 5; /* * Pop the list and get the index. @@ -4924,93 +3812,90 @@ TEBCresume( valuePtr = OBJ_AT_TOS; opnd = TclGetInt4AtPtr(pc+1); - TRACE(("\"%.30s\" %d => ", O2S(valuePtr), opnd)); - - /* special case for ArithSeries */ - if (TclHasInternalRep(valuePtr,&tclArithSeriesType)) { - length = TclArithSeriesObjLength(valuePtr); - - /* Decode end-offset index values. */ - - index = TclIndexDecode(opnd, length-1); - - /* Compute value @ index */ - if (index >= 0 && index < length) { - objResultPtr = TclArithSeriesObjIndex(interp, valuePtr, index); - if (objResultPtr == NULL) { - CACHE_STACK_INFO(); - TRACE_ERROR(interp); - goto gotError; - } - } else { - TclNewObj(objResultPtr); - } - pcAdjustment = 5; - goto lindexFastPath2; - } /* * 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_ERROR(interp); - goto gotError; - } + result = TclListObjGetElements(interp, valuePtr, &listc, &listv); - /* Decode end-offset index values. */ + if (result == TCL_OK) { + /* + * Select the list item based on the index. Negative operand means + * end-based indexing. + */ - index = TclIndexDecode(opnd, objc - 1); - pcAdjustment = 5; + if (opnd < -1) { + idx = opnd+1 + listc; + } else { + idx = opnd; + } - lindexFastPath: - if (index >= 0 && index < objc) { - objResultPtr = objv[index]; + lindexFastPath: + if (idx >= 0 && idx < listc) { + objResultPtr = listv[idx]; + } else { + TclNewObj(objResultPtr); + } + + TRACE_WITH_OBJ(("\"%.30s\" %d => ", O2S(valuePtr), opnd), + objResultPtr); + NEXT_INST_F(pcAdjustment, 1, 1); } else { - TclNewObj(objResultPtr); + TRACE_WITH_OBJ(("\"%.30s\" %d => ERROR: ", O2S(valuePtr), opnd), + Tcl_GetObjResult(interp)); + goto checkForCatch; } + } - lindexFastPath2: - - TRACE_APPEND(("\"%.30s\"\n", O2S(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; + opnd = TclGetUInt4AtPtr(pc+1); - numIndices = opnd-1; + numIdx = opnd-1; /* * Do the 'lindex' operation. */ - TRACE(("%d => ", opnd)); - objResultPtr = TclLindexFlat(interp, OBJ_AT_DEPTH(numIndices), - numIndices, &OBJ_AT_DEPTH(numIndices - 1)); - if (!objResultPtr) { - TRACE_ERROR(interp); - goto gotError; - } + objResultPtr = TclLindexFlat(interp, OBJ_AT_DEPTH(numIdx), + numIdx, &OBJ_AT_DEPTH(numIdx - 1)); /* - * Set result. + * Check for errors. */ - TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr))); - NEXT_INST_V(5, opnd, -1); + if (objResultPtr) { + /* + * Set result. + */ + + TRACE(("%d => %s\n", opnd, O2S(objResultPtr))); + NEXT_INST_V(5, opnd, -1); + } else { + TRACE_WITH_OBJ(("%d => ERROR: ", opnd), Tcl_GetObjResult(interp)); + result = TCL_ERROR; + goto checkForCatch; + } + } - case INST_LSET_FLAT: + case INST_LSET_FLAT: { /* * Lset with 3, 5, or more args. Get the number of index args. */ + int numIdx,opnd; + Tcl_Obj *valuePtr, *value2Ptr; + opnd = TclGetUInt4AtPtr(pc + 1); - numIndices = opnd - 2; - TRACE(("%d => ", opnd)); + numIdx = opnd - 2; /* * Get the old value of variable, and remove the stack ref. This is @@ -5019,28 +3904,47 @@ TEBCresume( * Tcl_DecrRefCount. */ - valuePtr = POP_OBJECT(); - Tcl_DecrRefCount(valuePtr); /* This one should be done here */ + value2Ptr = POP_OBJECT(); + Tcl_DecrRefCount(value2Ptr); /* This one should be done here */ + + /* + * Get the new element value. + */ + + valuePtr = OBJ_AT_TOS; /* * Compute the new variable value. */ - objResultPtr = TclLsetFlat(interp, valuePtr, numIndices, - &OBJ_AT_DEPTH(numIndices), OBJ_AT_TOS); - if (!objResultPtr) { - TRACE_ERROR(interp); - goto gotError; + objResultPtr = TclLsetFlat(interp, value2Ptr, numIdx, + &OBJ_AT_DEPTH(numIdx), valuePtr); + + /* + * Check for errors. + */ + + if (objResultPtr) { + /* + * Set result. + */ + + TRACE(("%d => %s\n", opnd, O2S(objResultPtr))); + NEXT_INST_V(5, (numIdx+1), -1); + } else { + TRACE_WITH_OBJ(("%d => ERROR: ", opnd), Tcl_GetObjResult(interp)); + result = TCL_ERROR; + goto checkForCatch; } + } + case INST_LSET_LIST: { /* - * Set result. + * 'lset' with 4 args. */ - TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr))); - NEXT_INST_V(5, numIndices+1, -1); + Tcl_Obj *objPtr, *valuePtr, *value2Ptr; - 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 @@ -5057,28 +3961,37 @@ TEBCresume( valuePtr = OBJ_AT_TOS; value2Ptr = OBJ_UNDER_TOS; - TRACE(("\"%.30s\" \"%.30s\" \"%.30s\" => ", - O2S(value2Ptr), O2S(valuePtr), O2S(objPtr))); /* * Compute the new variable value. */ objResultPtr = TclLsetList(interp, objPtr, value2Ptr, valuePtr); - if (!objResultPtr) { - TRACE_ERROR(interp); - goto gotError; - } /* - * Set result. + * Check for errors. */ - TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr))); - NEXT_INST_F(1, 2, -1); + if (objResultPtr) { + /* + * Set result. + */ + + TRACE(("=> %s\n", O2S(objResultPtr))); + NEXT_INST_F(1, 2, -1); + } else { + TRACE_WITH_OBJ(("\"%.30s\" => ERROR: ", O2S(value2Ptr)), + Tcl_GetObjResult(interp)); + result = TCL_ERROR; + goto checkForCatch; + } + } + + case INST_LIST_RANGE_IMM: { + /*** lrange with objc==4 and both indices in bytecode stream ***/ - case INST_LIST_RANGE_IMM: /* lrange with objc==4 and both indices in - * bytecode stream */ + int listc, fromIdx, toIdx; + Tcl_Obj **listv, *valuePtr; /* * Pop the list and get the indices. @@ -5087,127 +4000,121 @@ TEBCresume( valuePtr = OBJ_AT_TOS; fromIdx = TclGetInt4AtPtr(pc+1); toIdx = TclGetInt4AtPtr(pc+5); - TRACE(("\"%.30s\" %d %d => ", O2S(valuePtr), TclGetInt4AtPtr(pc+1), - TclGetInt4AtPtr(pc+5))); /* - * Get the length of the list, making sure that it really is a list + * Get the contents of the list, making sure that it really is a list * in the process. */ - - if (TclListObjLength(interp, valuePtr, &objc) != TCL_OK) { - TRACE_ERROR(interp); - goto gotError; - } + result = TclListObjGetElements(interp, valuePtr, &listc, &listv); /* * Skip a lot of work if we're about to throw the result away (common * with uses of [lassign]). */ + if (result == TCL_OK) { #ifndef TCL_COMPILE_DEBUG - if (*(pc+9) == INST_POP) { - NEXT_INST_F(10, 1, 0); - } -#endif - - /* Every range of an empty list is an empty list */ - if (objc == 0) { - /* avoid return of not canonical list (e. g. spaces in string repr.) */ - if (!valuePtr->bytes || !valuePtr->length) { - TRACE_APPEND(("\n")); - NEXT_INST_F(9, 0, 0); + if (*(pc+9) == INST_POP) { + NEXT_INST_F(10, 1, 0); } - goto emptyList; +#endif + } else { + TRACE_WITH_OBJ(("\"%.30s\" %d %d => ERROR: ", O2S(valuePtr), + fromIdx, toIdx), Tcl_GetObjResult(interp)); + goto checkForCatch; } - /* Decode index value operands. */ + /* + * Adjust the indices for end-based handling. + */ - if (toIdx == TCL_INDEX_NONE) { - emptyList: - TclNewObj(objResultPtr); - TRACE_APPEND(("\"%.30s\"", O2S(objResultPtr))); - NEXT_INST_F(9, 1, 1); + if (fromIdx < -1) { + fromIdx += 1+listc; + if (fromIdx < -1) { + fromIdx = -1; + } + } else if (fromIdx > listc) { + fromIdx = listc; } - toIdx = TclIndexDecode(toIdx, objc - 1); - if (toIdx < 0) { - goto emptyList; - } else if (toIdx >= objc) { - toIdx = objc - 1; + if (toIdx < -1) { + toIdx += 1+listc; + if (toIdx < -1) { + toIdx = -1; + } + } else if (toIdx > listc) { + toIdx = listc; } - assert (toIdx >= 0 && toIdx < objc); /* - assert ( fromIdx != TCL_INDEX_NONE ); - * - * Extra safety for legacy bytecodes: + * Check if we are referring to a valid, non-empty list range, and if + * so, build the list of elements in that range. */ - if (fromIdx == TCL_INDEX_NONE) { - fromIdx = TCL_INDEX_START; - } - - fromIdx = TclIndexDecode(fromIdx, objc - 1); - if (TclHasInternalRep(valuePtr,&tclArithSeriesType)) { - objResultPtr = TclArithSeriesObjRange(interp, valuePtr, fromIdx, toIdx); + if (fromIdx<=toIdx && fromIdx<listc && toIdx>=0) { + if (fromIdx<0) { + fromIdx = 0; + } + if (toIdx >= listc) { + toIdx = listc-1; + } + objResultPtr = Tcl_NewListObj(toIdx-fromIdx+1, listv+fromIdx); } else { - objResultPtr = TclListObjRange(interp, valuePtr, fromIdx, toIdx); - } - if (objResultPtr == NULL) { - TRACE_ERROR(interp); - goto gotError; + TclNewObj(objResultPtr); } - TRACE_APPEND(("\"%.30s\"", O2S(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. */ + case INST_LIST_NOT_IN: { + /* + * Basic list containment operators. + */ + + int found, s1len, s2len, llen, i; + Tcl_Obj *valuePtr, *value2Ptr, *o; + char *s1; + const char *s2; + value2Ptr = OBJ_AT_TOS; valuePtr = OBJ_UNDER_TOS; + /* TODO: Consider more efficient tests than strcmp() */ s1 = TclGetStringFromObj(valuePtr, &s1len); - TRACE(("\"%.30s\" \"%.30s\" => ", O2S(valuePtr), O2S(value2Ptr))); - if (TclListObjLength(interp, value2Ptr, &length) != TCL_OK) { - TRACE_ERROR(interp); - goto gotError; - } - match = 0; - if (length > 0) { - Tcl_Size i = 0; - Tcl_Obj *o; - int isArithSeries = TclHasInternalRep(value2Ptr,&tclArithSeriesType); + result = TclListObjLength(interp, value2Ptr, &llen); + if (result != TCL_OK) { + TRACE_WITH_OBJ(("\"%.30s\" \"%.30s\" => ERROR: ", O2S(valuePtr), + O2S(value2Ptr)), Tcl_GetObjResult(interp)); + goto checkForCatch; + } + found = 0; + if (llen > 0) { /* * An empty list doesn't match anything. */ + i = 0; do { - if (isArithSeries) { - o = TclArithSeriesObjIndex(NULL, value2Ptr, i); - } else { - Tcl_ListObjIndex(NULL, value2Ptr, i, &o); - } + Tcl_ListObjIndex(NULL, value2Ptr, i, &o); if (o != NULL) { s2 = TclGetStringFromObj(o, &s2len); } else { s2 = ""; - s2len = 0; } if (s1len == s2len) { - match = (memcmp(s1, s2, s1len) == 0); - } - if (isArithSeries) { - TclDecrRefCount(o); + found = (strcmp(s1, s2) == 0); } i++; - } while (i < length && match == 0); + } while (i < llen && found == 0); } if (*pc == INST_LIST_NOT_IN) { - match = !match; + found = !found; } - TRACE_APPEND(("%d\n", match)); + TRACE(("%.20s %.20s => %d\n", O2S(valuePtr), O2S(value2Ptr), found)); /* * Peep-hole optimisation: if you're about to jump, do jump from here. @@ -5215,141 +4122,154 @@ TEBCresume( * for branching. */ - JUMP_PEEPHOLE_F(match, 1, 2); - - case INST_LIST_CONCAT: - value2Ptr = OBJ_AT_TOS; - valuePtr = OBJ_UNDER_TOS; - TRACE(("\"%.30s\" \"%.30s\" => ", O2S(valuePtr), O2S(value2Ptr))); - if (Tcl_IsShared(valuePtr)) { - objResultPtr = Tcl_DuplicateObj(valuePtr); - if (Tcl_ListObjAppendList(interp, objResultPtr, - value2Ptr) != TCL_OK) { - TRACE_ERROR(interp); - TclDecrRefCount(objResultPtr); - goto gotError; - } - TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr))); - NEXT_INST_F(1, 2, 1); - } else { - if (Tcl_ListObjAppendList(interp, valuePtr, value2Ptr) != TCL_OK){ - TRACE_ERROR(interp); - goto gotError; - } - TRACE_APPEND(("\"%.30s\"\n", O2S(valuePtr))); - NEXT_INST_F(1, 1, 0); + pc++; +#ifndef TCL_COMPILE_DEBUG + switch (*pc) { + case INST_JUMP_FALSE1: + NEXT_INST_F((found ? 2 : TclGetInt1AtPtr(pc+1)), 2, 0); + case INST_JUMP_TRUE1: + NEXT_INST_F((found ? TclGetInt1AtPtr(pc+1) : 2), 2, 0); + case INST_JUMP_FALSE4: + NEXT_INST_F((found ? 5 : TclGetInt4AtPtr(pc+1)), 2, 0); + case INST_JUMP_TRUE4: + NEXT_INST_F((found ? TclGetInt4AtPtr(pc+1) : 5), 2, 0); } +#endif + objResultPtr = constants[found]; + NEXT_INST_F(0, 2, 1); + } - case INST_LREPLACE4: - { - TCL_HASH_TYPE numToDelete, numNewElems; - int end_indicator; - int haveSecondIndex, flags; - Tcl_Obj *fromIdxObj, *toIdxObj; - opnd = TclGetInt4AtPtr(pc + 1); - flags = TclGetInt1AtPtr(pc + 5); + /* + * End of INST_LIST and related instructions. + * --------------------------------------------------------- + */ - /* Stack: ... listobj index1 ?index2? new1 ... newN */ - valuePtr = OBJ_AT_DEPTH(opnd-1); + case INST_STR_EQ: + case INST_STR_NEQ: { + /* + * String (in)equality check + * TODO: Consider merging into INST_STR_CMP + */ - /* haveSecondIndex==0 => pure insert */ - haveSecondIndex = (flags & TCL_LREPLACE4_SINGLE_INDEX) == 0; - numNewElems = opnd - 2 - haveSecondIndex; + int iResult; + Tcl_Obj *valuePtr, *value2Ptr; - /* end_indicator==1 => "end" is last element's index, 0=>index beyond */ - end_indicator = (flags & TCL_LREPLACE4_END_IS_LAST) != 0; - fromIdxObj = OBJ_AT_DEPTH(opnd - 2); - toIdxObj = haveSecondIndex ? OBJ_AT_DEPTH(opnd - 3) : NULL; - if (Tcl_ListObjLength(interp, valuePtr, &length) != TCL_OK) { - TRACE_ERROR(interp); - goto gotError; - } + value2Ptr = OBJ_AT_TOS; + valuePtr = OBJ_UNDER_TOS; - DECACHE_STACK_INFO(); + if (valuePtr == value2Ptr) { + /* + * On the off-chance that the objects are the same, we don't + * really have to think hard about equality. + */ - if (TclGetIntForIndexM( - interp, fromIdxObj, length - end_indicator, &fromIdx) - != TCL_OK) { - CACHE_STACK_INFO(); - TRACE_ERROR(interp); - goto gotError; - } - if (fromIdx == TCL_INDEX_NONE) { - fromIdx = 0; - } else if (fromIdx > length) { - fromIdx = length; - } - numToDelete = 0; - if (toIdxObj) { - if (TclGetIntForIndexM( - interp, toIdxObj, length - end_indicator, &toIdx) - != TCL_OK) { - CACHE_STACK_INFO(); - TRACE_ERROR(interp); - goto gotError; - } - if (toIdx > length) { - toIdx = length; - } - if (toIdx >= fromIdx) { - numToDelete = (unsigned)toIdx - (unsigned)fromIdx + 1; /* See [3d3124d01d] */ - } - } + iResult = (*pc == INST_STR_EQ); + } else { + char *s1, *s2; + int s1len, s2len; - CACHE_STACK_INFO(); + s1 = TclGetStringFromObj(valuePtr, &s1len); + s2 = TclGetStringFromObj(value2Ptr, &s2len); + if (s1len == s2len) { + /* + * We only need to check (in)equality when we have equal + * length strings. + */ - if (Tcl_IsShared(valuePtr)) { - objResultPtr = Tcl_DuplicateObj(valuePtr); - if (Tcl_ListObjReplace(interp, - objResultPtr, - fromIdx, - numToDelete, - numNewElems, - &OBJ_AT_DEPTH(numNewElems - 1)) - != TCL_OK) { - TRACE_ERROR(interp); - Tcl_DecrRefCount(objResultPtr); - goto gotError; - } - TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr))); - NEXT_INST_V(6, opnd, 1); - } else { - if (Tcl_ListObjReplace(interp, - valuePtr, - fromIdx, - numToDelete, - numNewElems, - &OBJ_AT_DEPTH(numNewElems - 1)) - != TCL_OK) { - TRACE_ERROR(interp); - goto gotError; + if (*pc == INST_STR_NEQ) { + iResult = (strcmp(s1, s2) != 0); + } else { + /* INST_STR_EQ */ + iResult = (strcmp(s1, s2) == 0); + } + } else { + iResult = (*pc == INST_STR_NEQ); } - TRACE_APPEND(("\"%.30s\"\n", O2S(valuePtr))); - NEXT_INST_V(6, opnd - 1, 0); } + + TRACE(("%.20s %.20s => %d\n", O2S(valuePtr),O2S(value2Ptr),iResult)); + + /* + * 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((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 = constants[iResult]; + NEXT_INST_F(0, 2, 1); + } + case INST_STR_CMP: { /* - * End of INST_LIST and related instructions. - * ----------------------------------------------------------------- - * Start of string-related instructions. + * String compare. */ - case INST_STR_EQ: - case INST_STR_NEQ: /* String (in)equality check */ - case INST_STR_CMP: /* String compare. */ - case INST_STR_LT: - case INST_STR_GT: - case INST_STR_LE: - case INST_STR_GE: + const char *s1, *s2; + int s1len, s2len, iResult; + Tcl_Obj *valuePtr, *value2Ptr; + stringCompare: value2Ptr = OBJ_AT_TOS; valuePtr = OBJ_UNDER_TOS; - { - int checkEq = ((*pc == INST_EQ) || (*pc == INST_NEQ) - || (*pc == INST_STR_EQ) || (*pc == INST_STR_NEQ)); - match = TclStringCmp(valuePtr, value2Ptr, checkEq, 0, -1); + /* + * The comparison function should compare up to the minimum byte + * length only. + */ + + if (valuePtr == value2Ptr) { + /* + * In the pure equality case, set lengths too for the checks below + * (or we could goto beyond it). + */ + + iResult = s1len = s2len = 0; + } else if (TclIsPureByteArray(valuePtr) + && TclIsPureByteArray(value2Ptr)) { + 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. + */ + + 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 { + 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 = TclGetStringFromObj(valuePtr, &s1len); + s2 = TclGetStringFromObj(value2Ptr, &s2len); + iResult = TclpUtfNcmp2(s1, s2, + (size_t) ((s1len < s2len) ? s1len : s2len)); } /* @@ -5357,384 +4277,133 @@ TEBCresume( * TODO: consider peephole opt. */ + if (iResult == 0) { + iResult = s1len - s2len; + } + 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); + iResult = (iResult == 0); break; - case INST_STR_NEQ: case INST_NEQ: - match = (match != 0); + iResult = (iResult != 0); break; case INST_LT: - case INST_STR_LT: - match = (match < 0); + iResult = (iResult < 0); break; case INST_GT: - case INST_STR_GT: - match = (match > 0); + iResult = (iResult > 0); break; case INST_LE: - case INST_STR_LE: - match = (match <= 0); + iResult = (iResult <= 0); break; case INST_GE: - case INST_STR_GE: - match = (match >= 0); + iResult = (iResult >= 0); break; } } - - TRACE(("\"%.20s\" \"%.20s\" => %d\n", O2S(valuePtr), O2S(value2Ptr), - (match < 0 ? -1 : match > 0 ? 1 : 0))); - JUMP_PEEPHOLE_F(match, 1, 2); - - case INST_STR_LEN: - valuePtr = OBJ_AT_TOS; - length = TclGetCharLength(valuePtr); - TclNewIntObj(objResultPtr, length); - TRACE(("\"%.20s\" => %" TCL_SIZE_MODIFIER "d\n", O2S(valuePtr), length)); - NEXT_INST_F(1, 1, 1); - - case INST_STR_UPPER: - valuePtr = OBJ_AT_TOS; - TRACE(("\"%.20s\" => ", O2S(valuePtr))); - if (Tcl_IsShared(valuePtr)) { - s1 = TclGetStringFromObj(valuePtr, &length); - TclNewStringObj(objResultPtr, s1, length); - length = Tcl_UtfToUpper(TclGetString(objResultPtr)); - Tcl_SetObjLength(objResultPtr, length); - TRACE_APPEND(("\"%.20s\"\n", O2S(objResultPtr))); - NEXT_INST_F(1, 1, 1); - } else { - length = Tcl_UtfToUpper(TclGetString(valuePtr)); - Tcl_SetObjLength(valuePtr, length); - TclFreeInternalRep(valuePtr); - TRACE_APPEND(("\"%.20s\"\n", O2S(valuePtr))); - NEXT_INST_F(1, 0, 0); - } - case INST_STR_LOWER: - valuePtr = OBJ_AT_TOS; - TRACE(("\"%.20s\" => ", O2S(valuePtr))); - if (Tcl_IsShared(valuePtr)) { - s1 = TclGetStringFromObj(valuePtr, &length); - TclNewStringObj(objResultPtr, s1, length); - length = Tcl_UtfToLower(TclGetString(objResultPtr)); - Tcl_SetObjLength(objResultPtr, length); - TRACE_APPEND(("\"%.20s\"\n", O2S(objResultPtr))); - NEXT_INST_F(1, 1, 1); - } else { - length = Tcl_UtfToLower(TclGetString(valuePtr)); - Tcl_SetObjLength(valuePtr, length); - TclFreeInternalRep(valuePtr); - TRACE_APPEND(("\"%.20s\"\n", O2S(valuePtr))); - NEXT_INST_F(1, 0, 0); - } - case INST_STR_TITLE: - valuePtr = OBJ_AT_TOS; - TRACE(("\"%.20s\" => ", O2S(valuePtr))); - if (Tcl_IsShared(valuePtr)) { - s1 = TclGetStringFromObj(valuePtr, &length); - TclNewStringObj(objResultPtr, s1, length); - length = Tcl_UtfToTitle(TclGetString(objResultPtr)); - Tcl_SetObjLength(objResultPtr, length); - TRACE_APPEND(("\"%.20s\"\n", O2S(objResultPtr))); - NEXT_INST_F(1, 1, 1); - } else { - length = Tcl_UtfToTitle(TclGetString(valuePtr)); - Tcl_SetObjLength(valuePtr, length); - TclFreeInternalRep(valuePtr); - TRACE_APPEND(("\"%.20s\"\n", O2S(valuePtr))); - NEXT_INST_F(1, 0, 0); - } - - case INST_STR_INDEX: - value2Ptr = OBJ_AT_TOS; - valuePtr = OBJ_UNDER_TOS; - TRACE(("\"%.20s\" %.20s => ", O2S(valuePtr), O2S(value2Ptr))); - - /* - * Get char length to calculate what 'end' means. - */ - - length = TclGetCharLength(valuePtr); - DECACHE_STACK_INFO(); - if (TclGetIntForIndexM(interp, value2Ptr, length-1, &index)!=TCL_OK) { - CACHE_STACK_INFO(); - TRACE_ERROR(interp); - goto gotError; - } - CACHE_STACK_INFO(); - - if ((index < 0) || (index >= length)) { - TclNewObj(objResultPtr); - } else if (TclIsPureByteArray(valuePtr)) { - objResultPtr = Tcl_NewByteArrayObj( - Tcl_GetByteArrayFromObj(valuePtr, NULL)+index, 1); - } else if (valuePtr->bytes && length == valuePtr->length) { - objResultPtr = Tcl_NewStringObj((const char *) - valuePtr->bytes+index, 1); + if (iResult < 0) { + TclNewIntObj(objResultPtr, -1); + TRACE(("%.20s %.20s => %d\n", O2S(valuePtr), O2S(value2Ptr), -1)); } else { - char buf[4] = ""; - int ch = TclGetUniChar(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. - */ - if (ch == -1) { - TclNewObj(objResultPtr); - } else { - length = Tcl_UniCharToUtf(ch, buf); - if ((ch >= 0xD800) && (length < 3)) { - length += Tcl_UniCharToUtf(-1, buf + length); - } - objResultPtr = Tcl_NewStringObj(buf, length); - } + objResultPtr = constants[(iResult>0)]; + TRACE(("%.20s %.20s => %d\n", O2S(valuePtr), O2S(value2Ptr), + (iResult > 0))); } - TRACE_APPEND(("\"%s\"\n", O2S(objResultPtr))); NEXT_INST_F(1, 2, 1); + } - case INST_STR_RANGE: - TRACE(("\"%.20s\" %.20s %.20s =>", - O2S(OBJ_AT_DEPTH(2)), O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS))); - length = TclGetCharLength(OBJ_AT_DEPTH(2)) - 1; + case INST_STR_LEN: { + int length; + Tcl_Obj *valuePtr; - DECACHE_STACK_INFO(); - if (TclGetIntForIndexM(interp, OBJ_UNDER_TOS, length, - &fromIdx) != TCL_OK) { - CACHE_STACK_INFO(); - TRACE_ERROR(interp); - goto gotError; - } - if (TclGetIntForIndexM(interp, OBJ_AT_TOS, length, - &toIdx) != TCL_OK) { - CACHE_STACK_INFO(); - TRACE_ERROR(interp); - goto gotError; - } - CACHE_STACK_INFO(); + valuePtr = OBJ_AT_TOS; - if (toIdx < 0) { - TclNewObj(objResultPtr); + if (valuePtr->typePtr == &tclByteArrayType) { + (void) Tcl_GetByteArrayFromObj(valuePtr, &length); } else { - objResultPtr = TclGetRange(OBJ_AT_DEPTH(2), fromIdx, toIdx); + length = Tcl_GetCharLength(valuePtr); } - TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr))); - NEXT_INST_V(1, 3, 1); + TclNewIntObj(objResultPtr, length); + TRACE(("%.20s => %d\n", O2S(valuePtr), length)); + NEXT_INST_F(1, 1, 1); + } - case INST_STR_RANGE_IMM: - valuePtr = OBJ_AT_TOS; - fromIdx = TclGetInt4AtPtr(pc+1); - toIdx = TclGetInt4AtPtr(pc+5); - length = TclGetCharLength(valuePtr); - TRACE(("\"%.20s\" %d %d => ", O2S(valuePtr), fromIdx, toIdx)); + case INST_STR_INDEX: { + /* + * String compare. + */ - /* Every range of an empty value is an empty value */ - if (length == 0) { - TRACE_APPEND(("\n")); - NEXT_INST_F(9, 0, 0); - } + int index, length; + char *bytes; + Tcl_Obj *valuePtr, *value2Ptr; - /* Decode index operands. */ + bytes = NULL; /* lint */ + value2Ptr = OBJ_AT_TOS; + valuePtr = OBJ_UNDER_TOS; /* - assert ( toIdx != TCL_INDEX_NONE ); - * - * Extra safety for legacy bytecodes: + * 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 (toIdx == TCL_INDEX_NONE) { - TclNewObj(objResultPtr); + + if (TclIsPureByteArray(valuePtr)) { + bytes = (char *)Tcl_GetByteArrayFromObj(valuePtr, &length); } else { - toIdx = TclIndexDecode(toIdx, length - 1); /* - assert ( fromIdx != TCL_INDEX_NONE ); - * - * Extra safety for legacy bytecodes: + * Get Unicode char length to calulate what 'end' means. */ - if (fromIdx == TCL_INDEX_NONE) { - fromIdx = TCL_INDEX_START; - } - fromIdx = TclIndexDecode(fromIdx, length - 1); - if (toIdx < 0) { - TclNewObj(objResultPtr); - } else { - objResultPtr = TclGetRange(valuePtr, fromIdx, toIdx); - } - } - TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); - NEXT_INST_F(9, 1, 1); - - { - Tcl_UniChar *ustring1, *ustring2, *ustring3, *end, *p; - Tcl_Size length3, endIdx; - Tcl_Obj *value3Ptr; - - case INST_STR_REPLACE: - value3Ptr = POP_OBJECT(); - valuePtr = OBJ_AT_DEPTH(2); - endIdx = TclGetCharLength(valuePtr) - 1; - TRACE(("\"%.20s\" %s %s \"%.20s\" => ", O2S(valuePtr), - O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS), O2S(value3Ptr))); - DECACHE_STACK_INFO(); - if (TclGetIntForIndexM(interp, OBJ_UNDER_TOS, endIdx, - &fromIdx) != TCL_OK - || TclGetIntForIndexM(interp, OBJ_AT_TOS, endIdx, - &toIdx) != TCL_OK) { - CACHE_STACK_INFO(); - TclDecrRefCount(value3Ptr); - TRACE_ERROR(interp); - goto gotError; - } - CACHE_STACK_INFO(); - TclDecrRefCount(OBJ_AT_TOS); - (void) POP_OBJECT(); - TclDecrRefCount(OBJ_AT_TOS); - (void) POP_OBJECT(); - - if ((toIdx < 0) || - (fromIdx > endIdx) || - (toIdx < fromIdx)) { - TRACE_APPEND(("\"%.30s\"\n", O2S(valuePtr))); - TclDecrRefCount(value3Ptr); - NEXT_INST_F(1, 0, 0); - } - - if (fromIdx < 0) { - fromIdx = 0; - } - if (toIdx > endIdx) { - toIdx = endIdx; + length = Tcl_GetCharLength(valuePtr); } - if ((fromIdx == 0) && (toIdx == endIdx)) { - TclDecrRefCount(OBJ_AT_TOS); - OBJ_AT_TOS = value3Ptr; - TRACE_APPEND(("\"%.30s\"\n", O2S(value3Ptr))); - NEXT_INST_F(1, 0, 0); + result = TclGetIntForIndexM(interp, value2Ptr, length - 1, &index); + if (result != TCL_OK) { + goto checkForCatch; } - objResultPtr = TclStringReplace(interp, valuePtr, fromIdx, - toIdx - fromIdx + 1, value3Ptr, TCL_STRING_IN_PLACE); + if ((index >= 0) && (index < length)) { + if (TclIsPureByteArray(valuePtr)) { + 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; - if (objResultPtr == value3Ptr) { - /* See [Bug 82e7f67325] */ - TclDecrRefCount(OBJ_AT_TOS); - OBJ_AT_TOS = value3Ptr; - TRACE_APPEND(("\"%.30s\"\n", O2S(value3Ptr))); - NEXT_INST_F(1, 0, 0); - } - TclDecrRefCount(value3Ptr); - TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr))); - NEXT_INST_F(1, 1, 1); + ch = Tcl_GetUniChar(valuePtr, index); - case INST_STR_MAP: - valuePtr = OBJ_AT_TOS; /* "Main" string. */ - value3Ptr = OBJ_UNDER_TOS; /* "Target" string. */ - value2Ptr = OBJ_AT_DEPTH(2); /* "Source" string. */ - if (value3Ptr == value2Ptr) { - objResultPtr = valuePtr; - goto doneStringMap; - } else if (valuePtr == value2Ptr) { - objResultPtr = value3Ptr; - goto doneStringMap; - } - ustring1 = TclGetUnicodeFromObj(valuePtr, &length); - if (length == 0) { - objResultPtr = valuePtr; - goto doneStringMap; - } - ustring2 = TclGetUnicodeFromObj(value2Ptr, &length2); - if (length2 > length || length2 == 0) { - objResultPtr = valuePtr; - goto doneStringMap; - } else if (length2 == length) { - if (memcmp(ustring1, ustring2, sizeof(Tcl_UniChar) * length)) { - objResultPtr = valuePtr; - } else { - objResultPtr = value3Ptr; - } - goto doneStringMap; - } - ustring3 = TclGetUnicodeFromObj(value3Ptr, &length3); - - objResultPtr = TclNewUnicodeObj(ustring1, 0); - p = ustring1; - end = ustring1 + length; - for (; ustring1 < end; ustring1++) { - if ((*ustring1 == *ustring2) && - /* Fix bug [69218ab7b]: restrict max compare length. */ - ((end-ustring1) >= length2) && (length2==1 || - memcmp(ustring1, ustring2, sizeof(Tcl_UniChar) * length2) - == 0)) { - if (p != ustring1) { - TclAppendUnicodeToObj(objResultPtr, p, ustring1-p); - p = ustring1 + length2; - } else { - p += length2; - } - ustring1 = p - 1; + /* + * This could be: Tcl_NewUnicodeObj((const Tcl_UniChar *)&ch, + * 1) but creating the object as a string seems to be faster + * in practical use. + */ - TclAppendUnicodeToObj(objResultPtr, ustring3, length3); + length = Tcl_UniCharToUtf(ch, buf); + objResultPtr = Tcl_NewStringObj(buf, length); } + } else { + TclNewObj(objResultPtr); } - if (p != ustring1) { - /* - * Put the rest of the unmapped chars onto result. - */ - - TclAppendUnicodeToObj(objResultPtr, p, ustring1 - p); - } - doneStringMap: - TRACE_WITH_OBJ(("%.20s %.20s %.20s => ", - O2S(value2Ptr), O2S(value3Ptr), O2S(valuePtr)), objResultPtr); - NEXT_INST_V(1, 3, 1); - case INST_STR_FIND: - objResultPtr = TclStringFirst(OBJ_UNDER_TOS, OBJ_AT_TOS, 0); - - TRACE(("%.20s %.20s => %s\n", - O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS), O2S(objResultPtr))); + TRACE(("%.20s %.20s => %s\n", O2S(valuePtr), O2S(value2Ptr), + O2S(objResultPtr))); NEXT_INST_F(1, 2, 1); - - case INST_STR_FIND_LAST: - objResultPtr = TclStringLast(OBJ_UNDER_TOS, OBJ_AT_TOS, INT_MAX - 1); - - TRACE(("%.20s %.20s => %s\n", - O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS), O2S(objResultPtr))); - NEXT_INST_F(1, 2, 1); - - case INST_STR_CLASS: - opnd = TclGetInt1AtPtr(pc+1); - valuePtr = OBJ_AT_TOS; - TRACE(("%s \"%.30s\" => ", tclStringClassTable[opnd].name, - O2S(valuePtr))); - ustring1 = TclGetUnicodeFromObj(valuePtr, &length); - match = 1; - if (length > 0) { - int ch; - end = ustring1 + length; - for (p=ustring1 ; p<end ; ) { - ch = *p++; - if (!tclStringClassTable[opnd].comparator(ch)) { - match = 0; - break; - } - } - } - TRACE_APPEND(("%d\n", match)); - JUMP_PEEPHOLE_F(match, 2, 1); } - case INST_STR_MATCH: + case INST_STR_MATCH: { + int nocase, match; + Tcl_Obj *valuePtr, *value2Ptr; + nocase = TclGetInt1AtPtr(pc+1); valuePtr = OBJ_AT_TOS; /* String */ value2Ptr = OBJ_UNDER_TOS; /* Pattern */ @@ -5744,20 +4413,22 @@ TEBCresume( * both. */ - if (TclHasInternalRep(valuePtr, &tclUniCharStringType) - || TclHasInternalRep(value2Ptr, &tclUniCharStringType)) { + if ((valuePtr->typePtr == &tclStringType) + || (value2Ptr->typePtr == &tclStringType)) { Tcl_UniChar *ustring1, *ustring2; + int length1, length2; - ustring1 = TclGetUnicodeFromObj(valuePtr, &length); - ustring2 = TclGetUnicodeFromObj(value2Ptr, &length2); - match = TclUniCharMatch(ustring1, length, ustring2, length2, + ustring1 = Tcl_GetUnicodeFromObj(valuePtr, &length1); + ustring2 = Tcl_GetUnicodeFromObj(value2Ptr, &length2); + match = TclUniCharMatch(ustring1, length1, ustring2, length2, nocase); } else if (TclIsPureByteArray(valuePtr) && !nocase) { - unsigned char *bytes1, *bytes2; + unsigned char *string1, *string2; + int length1, length2; - bytes1 = Tcl_GetByteArrayFromObj(valuePtr, &length); - bytes2 = Tcl_GetByteArrayFromObj(value2Ptr, &length2); - match = TclByteArrayMatch(bytes1, length, bytes2, length2, 0); + string1 = Tcl_GetByteArrayFromObj(valuePtr, &length1); + string2 = Tcl_GetByteArrayFromObj(value2Ptr, &length2); + match = TclByteArrayMatch(string1, length1, string2, length2, 0); } else { match = Tcl_StringCaseMatch(TclGetString(valuePtr), TclGetString(value2Ptr), nocase); @@ -5766,128 +4437,47 @@ TEBCresume( /* * Reuse value2Ptr object already on stack if possible. Adjustment is * 2 due to the nocase byte + * TODO: consider peephole opt. */ TRACE(("%.20s %.20s => %d\n", O2S(valuePtr), O2S(value2Ptr), match)); - - /* - * Peep-hole optimisation: if you're about to jump, do jump from here. - */ - - JUMP_PEEPHOLE_F(match, 2, 2); - - { - const char *string1, *string2; - Tcl_Size trim1, trim2; - - case INST_STR_TRIM_LEFT: - valuePtr = OBJ_UNDER_TOS; /* String */ - value2Ptr = OBJ_AT_TOS; /* TrimSet */ - string2 = TclGetStringFromObj(value2Ptr, &length2); - string1 = TclGetStringFromObj(valuePtr, &length); - trim1 = TclTrimLeft(string1, length, string2, length2); - trim2 = 0; - goto createTrimmedString; - case INST_STR_TRIM_RIGHT: - valuePtr = OBJ_UNDER_TOS; /* String */ - value2Ptr = OBJ_AT_TOS; /* TrimSet */ - string2 = TclGetStringFromObj(value2Ptr, &length2); - string1 = TclGetStringFromObj(valuePtr, &length); - trim2 = TclTrimRight(string1, length, string2, length2); - trim1 = 0; - goto createTrimmedString; - case INST_STR_TRIM: - valuePtr = OBJ_UNDER_TOS; /* String */ - value2Ptr = OBJ_AT_TOS; /* TrimSet */ - string2 = TclGetStringFromObj(value2Ptr, &length2); - string1 = TclGetStringFromObj(valuePtr, &length); - trim1 = TclTrim(string1, length, string2, length2, &trim2); - createTrimmedString: - /* - * Careful here; trim set often contains non-ASCII characters so we - * take care when printing. [Bug 971cb4f1db] - */ - -#ifdef TCL_COMPILE_DEBUG - if (traceInstructions) { - TRACE(("\"%.30s\" ", O2S(valuePtr))); - TclPrintObject(stdout, value2Ptr, 30); - printf(" => "); - } -#endif - if (trim1 == 0 && trim2 == 0) { -#ifdef TCL_COMPILE_DEBUG - if (traceInstructions) { - TclPrintObject(stdout, valuePtr, 30); - printf("\n"); - } -#endif - NEXT_INST_F(1, 1, 0); - } else { - objResultPtr = Tcl_NewStringObj(string1+trim1, length-trim1-trim2); -#ifdef TCL_COMPILE_DEBUG - if (traceInstructions) { - TclPrintObject(stdout, objResultPtr, 30); - printf("\n"); - } -#endif - NEXT_INST_F(1, 2, 1); - } + objResultPtr = constants[match]; + NEXT_INST_F(2, 2, 1); } - case INST_REGEXP: + case INST_REGEXP: { + int cflags, match; + Tcl_Obj *valuePtr, *value2Ptr; + Tcl_RegExp regExpr; + cflags = TclGetInt1AtPtr(pc+1); /* RE compile flages like NOCASE */ valuePtr = OBJ_AT_TOS; /* String */ value2Ptr = OBJ_UNDER_TOS; /* Pattern */ - TRACE(("\"%.30s\" \"%.30s\" => ", O2S(valuePtr), O2S(value2Ptr))); - - /* - * Compile and match the regular expression. - */ - { - Tcl_RegExp regExpr = - Tcl_GetRegExpFromObj(interp, value2Ptr, cflags); - - if (regExpr == NULL) { - TRACE_ERROR(interp); - goto gotError; - } + regExpr = Tcl_GetRegExpFromObj(interp, value2Ptr, cflags); + if (regExpr == NULL) { + match = -1; + } else { match = Tcl_RegExpExecObj(interp, regExpr, valuePtr, 0, 0, 0); - if (match < 0) { - TRACE_ERROR(interp); - goto gotError; - } } - TRACE_APPEND(("%d\n", match)); - /* - * Peep-hole optimisation: if you're about to jump, do jump from here. - * Adjustment is 2 due to the nocase byte. + * Adjustment is 2 due to the nocase byte */ - JUMP_PEEPHOLE_F(match, 2, 2); - } - - /* - * End of string-related instructions. - * ----------------------------------------------------------------- - * Start of numeric operator instructions. - */ - - { - void *ptr1, *ptr2; - int type1, type2; - Tcl_WideInt w1, w2, wResult; - - case INST_NUM_TYPE: - if (GetNumberFromObj(NULL, OBJ_AT_TOS, &ptr1, &type1) != TCL_OK) { - type1 = 0; + if (match < 0) { + objResultPtr = Tcl_GetObjResult(interp); + TRACE_WITH_OBJ(("%.20s %.20s => ERROR: ", + O2S(valuePtr), O2S(value2Ptr)), objResultPtr); + result = TCL_ERROR; + goto checkForCatch; + } else { + TRACE(("%.20s %.20s => %d\n", + O2S(valuePtr), O2S(value2Ptr), match)); + objResultPtr = constants[match]; + NEXT_INST_F(2, 2, 1); } - TclNewIntObj(objResultPtr, type1); - TRACE(("\"%.20s\" => %d\n", O2S(OBJ_AT_TOS), type1)); - NEXT_INST_F(1, 1, 1); + } case INST_EQ: case INST_NEQ: @@ -5895,30 +4485,27 @@ TEBCresume( case INST_GT: case INST_LE: case INST_GE: { - int iResult = 0, compare = 0; - - value2Ptr = OBJ_AT_TOS; - valuePtr = OBJ_UNDER_TOS; - - /* - Try to determine, without triggering generation of a string - representation, whether one value is not a number. - */ - if (TclCheckEmptyString(valuePtr) > 0 || TclCheckEmptyString(value2Ptr) > 0) { - goto stringCompare; - } + Tcl_Obj *valuePtr = OBJ_UNDER_TOS; + Tcl_Obj *value2Ptr = OBJ_AT_TOS; + ClientData ptr1, ptr2; + int iResult = 0, compare = 0, type1, type2; + double d1, d2, tmp; + long l1, l2; + mp_int big1, big2; +#ifndef NO_WIDE_TYPE + Tcl_WideInt w1, w2; +#endif - if (GetNumberFromObj(NULL, valuePtr, &ptr1, &type1) != TCL_OK - || GetNumberFromObj(NULL, value2Ptr, &ptr2, &type2) != TCL_OK) { + if (GetNumberFromObj(NULL, valuePtr, &ptr1, &type1) != TCL_OK) { /* * At least one non-numeric argument - compare as strings. */ goto stringCompare; } - if (type1 == TCL_NUMBER_NAN || type2 == TCL_NUMBER_NAN) { + if (type1 == TCL_NUMBER_NAN) { /* - * NaN arg: NaN != to everything, other compares are false. + * NaN first arg: NaN != to everything, other compares are false. */ iResult = (*pc == INST_NEQ); @@ -5928,12 +4515,237 @@ TEBCresume( compare = MP_EQ; goto convertComparison; } - if ((type1 == TCL_NUMBER_INT) && (type2 == TCL_NUMBER_INT)) { + if (GetNumberFromObj(NULL, value2Ptr, &ptr2, &type2) != TCL_OK) { + /* + * At least one non-numeric argument - compare as strings. + */ + + goto stringCompare; + } + if (type2 == TCL_NUMBER_NAN) { + /* + * NaN 2nd arg: NaN != to everything, other compares are false. + */ + + iResult = (*pc == INST_NEQ); + goto foundResult; + } + switch (type1) { + case TCL_NUMBER_LONG: + l1 = *((const long *)ptr1); + switch (type2) { + case TCL_NUMBER_LONG: + l2 = *((const long *)ptr2); + longCompare: + compare = (l1 < l2) ? MP_LT : ((l1 > l2) ? MP_GT : MP_EQ); + break; +#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) { + compare = MP_GT; + break; + } + if (d2 > (double)LONG_MAX) { + compare = MP_LT; + break; + } + 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); + } + break; + +#ifndef NO_WIDE_TYPE + case TCL_NUMBER_WIDE: w1 = *((const Tcl_WideInt *)ptr1); - w2 = *((const Tcl_WideInt *)ptr2); - compare = (w1 < w2) ? MP_LT : ((w1 > w2) ? MP_GT : MP_EQ); - } else { - compare = TclCompareTwoNumbers(valuePtr, value2Ptr); + switch (type2) { + case TCL_NUMBER_WIDE: + w2 = *((const Tcl_WideInt *)ptr2); + wideCompare: + compare = (w1 < w2) ? MP_LT : ((w1 > w2) ? MP_GT : MP_EQ); + break; + 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) { + compare = MP_GT; + break; + } + if (d2 > (double)LLONG_MAX) { + compare = MP_LT; + break; + } + 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); + } + break; +#endif + + case TCL_NUMBER_DOUBLE: + d1 = *((const double *)ptr1); + switch (type2) { + case TCL_NUMBER_DOUBLE: + d2 = *((const double *)ptr2); + doubleCompare: + compare = (d1 < d2) ? MP_LT : ((d1 > d2) ? MP_GT : MP_EQ); + break; + 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) { + compare = MP_LT; + break; + } + if (d1 > (double)LONG_MAX) { + compare = MP_GT; + break; + } + 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) { + compare = MP_LT; + break; + } + if (d1 > (double)LLONG_MAX) { + compare = MP_GT; + break; + } + w1 = (Tcl_WideInt) d1; + goto wideCompare; +#endif + case TCL_NUMBER_BIG: + if (TclIsInfinite(d1)) { + compare = (d1 > 0.0) ? MP_GT : MP_LT; + break; + } + 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); + break; + } + 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; + } + break; + + 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); + break; + case TCL_NUMBER_DOUBLE: + d2 = *((const double *)ptr2); + if (TclIsInfinite(d2)) { + compare = (d2 > 0.0) ? MP_LT : MP_GT; + mp_clear(&big1); + break; + } + if ((d2 < (double)LONG_MAX) && (d2 > (double)LONG_MIN)) { + compare = mp_cmp_d(&big1, 0); + mp_clear(&big1); + break; + } + 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); + } } /* @@ -5967,250 +4779,758 @@ TEBCresume( */ foundResult: - TRACE(("\"%.20s\" \"%.20s\" => %d\n", O2S(valuePtr), O2S(value2Ptr), - iResult)); - JUMP_PEEPHOLE_F(iResult, 1, 2); + 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); + } +#endif + objResultPtr = constants[iResult]; + NEXT_INST_F(0, 2, 1); } case INST_MOD: case INST_LSHIFT: - case INST_RSHIFT: - 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)) { + case INST_RSHIFT: { + Tcl_Obj *value2Ptr = OBJ_AT_TOS; + Tcl_Obj *valuePtr = OBJ_UNDER_TOS; + ClientData ptr1, ptr2; + int invalid, shift, type1, type2; + long l1 = 0; + + result = GetNumberFromObj(NULL, valuePtr, &ptr1, &type1); + if ((result != TCL_OK) || (type1 == TCL_NUMBER_DOUBLE) + || (type1 == TCL_NUMBER_NAN)) { + result = TCL_ERROR; 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; + goto checkForCatch; } - if ((GetNumberFromObj(NULL, value2Ptr, &ptr2, &type2) != TCL_OK) - || (type2==TCL_NUMBER_DOUBLE) || (type2==TCL_NUMBER_NAN)) { + result = GetNumberFromObj(NULL, value2Ptr, &ptr2, &type2); + if ((result != TCL_OK) || (type2 == TCL_NUMBER_DOUBLE) + || (type2 == TCL_NUMBER_NAN)) { + result = TCL_ERROR; 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; + goto checkForCatch; } - /* - * Check for common, simple case. - */ + if (*pc == INST_MOD) { + /* TODO: Attempts to re-use unshared operands on stack */ - if ((type1 == TCL_NUMBER_INT) && (type2 == TCL_NUMBER_INT)) { - w1 = *((const Tcl_WideInt *)ptr1); - w2 = *((const Tcl_WideInt *)ptr2); + long l2 = 0; /* silence gcc warning */ - switch (*pc) { - case INST_MOD: - if (w2 == 0) { + if (type2 == TCL_NUMBER_LONG) { + l2 = *((const long *)ptr2); + if (l2 == 0) { TRACE(("%s %s => DIVIDE BY ZERO\n", O2S(valuePtr), O2S(value2Ptr))); goto divideByZero; - } else if ((w2 == 1) || (w2 == -1)) { + } + if ((l2 == 1) || (l2 == -1)) { /* * Div. by |1| always yields remainder of 0. */ - TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); - objResultPtr = TCONST(0); + objResultPtr = constants[0]; TRACE(("%s\n", O2S(objResultPtr))); NEXT_INST_F(1, 2, 1); - } else if (w1 == 0) { + } + } + if (type1 == TCL_NUMBER_LONG) { + l1 = *((const long *)ptr1); + if (l1 == 0) { /* * 0 % (non-zero) always yields remainder of 0. */ - TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); - objResultPtr = TCONST(0); + objResultPtr = constants[0]; TRACE(("%s\n", O2S(objResultPtr))); NEXT_INST_F(1, 2, 1); - } else { - wResult = w1 / w2; + } + if (type2 == TCL_NUMBER_LONG) { + /* + * Both operands are long; do native calculation. + */ + + long lRemainder, lQuotient = l1 / l2; /* * 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; + if ((lQuotient < 0 || (lQuotient == 0 && + ((l1 < 0 && l2 > 0) || (l1 > 0 && l2 < 0)))) && + (lQuotient * l2 != l1)) { + lQuotient -= 1; } - wResult = (Tcl_WideInt)((Tcl_WideUInt)w1 - - (Tcl_WideUInt)w2*(Tcl_WideUInt)wResult); - goto wideResultOfArithmetic; - } - break; - - case INST_RSHIFT: - if (w2 < 0) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "negative shift argument", -1)); -#ifdef ERROR_CODE_FOR_EARLY_DETECTED_ARITH_ERROR - DECACHE_STACK_INFO(); - Tcl_SetErrorCode(interp, "ARITH", "DOMAIN", - "domain error: argument not in valid range", - (void *)NULL); - CACHE_STACK_INFO(); -#endif /* ERROR_CODE_FOR_EARLY_DETECTED_ARITH_ERROR */ - goto gotError; - } else if (w1 == 0) { - TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); - objResultPtr = TCONST(0); + lRemainder = l1 - l2*lQuotient; + TclNewLongObj(objResultPtr, lRemainder); TRACE(("%s\n", O2S(objResultPtr))); NEXT_INST_F(1, 2, 1); - } else { + } + + /* + * First operand fits in long; second does not, so the second + * has greater magnitude than first. No need to divide to + * determine the remainder. + */ + +#ifndef NO_WIDE_TYPE + if (type2 == TCL_NUMBER_WIDE) { + Tcl_WideInt w2 = *((const Tcl_WideInt *)ptr2); + + if ((l1 > 0) ^ (w2 > (Tcl_WideInt)0)) { + /* + * Arguments are opposite sign; remainder is sum. + */ + + objResultPtr = Tcl_NewWideIntObj(w2+(Tcl_WideInt)l1); + TRACE(("%s\n", O2S(objResultPtr))); + NEXT_INST_F(1, 2, 1); + } + /* - * Quickly force large right shifts to 0 or -1. + * Arguments are same sign; remainder is first operand. */ - if (w2 >= (Tcl_WideInt)(CHAR_BIT*sizeof(w1))) { + TRACE(("%s\n", O2S(valuePtr))); + NEXT_INST_F(1, 1, 0); + } +#endif + { + mp_int big2; + + Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2); + + /* TODO: internals intrusion */ + if ((l1 > 0) ^ (big2.sign == MP_ZPOS)) { /* - * We assume that INT_MAX is much larger than the - * number of bits in a Tcl_WideInt. This is a pretty safe - * assumption, given that the former is usually around - * 4e9 and the latter 64... + * Arguments are opposite sign; remainder is sum. */ - TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); - if (w1 > 0L) { - objResultPtr = TCONST(0); - } else { - TclNewIntObj(objResultPtr, -1); - } + mp_int big1; + + TclBNInitBignumFromLong(&big1, l1); + mp_add(&big2, &big1, &big2); + mp_clear(&big1); + objResultPtr = Tcl_NewBignumObj(&big2); TRACE(("%s\n", O2S(objResultPtr))); NEXT_INST_F(1, 2, 1); } /* - * Handle shifts within the native Tcl_WideInt range. + * Arguments are same sign; remainder is first operand. */ - wResult = w1 >> ((int) w2); - goto wideResultOfArithmetic; + mp_clear(&big2); + TRACE(("%s\n", O2S(valuePtr))); + NEXT_INST_F(1, 1, 0); } - break; + } +#ifndef NO_WIDE_TYPE + if (type1 == TCL_NUMBER_WIDE) { + Tcl_WideInt w1 = *((const Tcl_WideInt *)ptr1); - case INST_LSHIFT: - if (w2 < 0) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "negative shift argument", -1)); -#ifdef ERROR_CODE_FOR_EARLY_DETECTED_ARITH_ERROR - DECACHE_STACK_INFO(); - Tcl_SetErrorCode(interp, "ARITH", "DOMAIN", - "domain error: argument not in valid range", - (void *)NULL); - CACHE_STACK_INFO(); -#endif /* ERROR_CODE_FOR_EARLY_DETECTED_ARITH_ERROR */ - goto gotError; - } else if (w1 == 0) { - TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); - objResultPtr = TCONST(0); + if (type2 != TCL_NUMBER_BIG) { + Tcl_WideInt w2, 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; + objResultPtr = Tcl_NewWideIntObj(wRemainder); TRACE(("%s\n", O2S(objResultPtr))); NEXT_INST_F(1, 2, 1); - } else if (w2 > INT_MAX) { + } + { + mp_int big2; + Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2); + + /* TODO: internals intrusion */ + if ((w1 > ((Tcl_WideInt) 0)) ^ (big2.sign == MP_ZPOS)) { + /* + * Arguments are opposite sign; remainder is sum. + */ + + mp_int big1; + + TclBNInitBignumFromWideInt(&big1, w1); + mp_add(&big2, &big1, &big2); + mp_clear(&big1); + objResultPtr = Tcl_NewBignumObj(&big2); + TRACE(("%s\n", O2S(objResultPtr))); + NEXT_INST_F(1, 2, 1); + } + /* - * 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. + * Arguments are same sign; remainder is first operand. */ - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "integer value too large to represent", -1)); -#ifdef ERROR_CODE_FOR_EARLY_DETECTED_ARITH_ERROR - DECACHE_STACK_INFO(); - Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", - "integer value too large to represent", (void *)NULL); - CACHE_STACK_INFO(); -#endif /* ERROR_CODE_FOR_EARLY_DETECTED_ARITH_ERROR */ - goto gotError; - } else { - int shift = (int) w2; - + mp_clear(&big2); + TRACE(("%s\n", O2S(valuePtr))); + NEXT_INST_F(1, 1, 0); + } + } +#endif + { + mp_int big1, big2, bigResult, bigRemainder; + + 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)) { /* - * Handle shifts within the native Tcl_WideInt range. + * Convert to Tcl's integer division rules. */ - if (((size_t)shift < CHAR_BIT*sizeof(w1)) - && !((w1>0 ? w1 : ~w1) & - -((Tcl_WideUInt)1<<(CHAR_BIT*sizeof(w1) - 1 - shift)))) { - wResult = (Tcl_WideUInt)w1 << shift; - goto wideResultOfArithmetic; - } + mp_sub_d(&bigResult, 1, &bigResult); + mp_add(&bigRemainder, &big2, &bigRemainder); + } + mp_copy(&bigRemainder, &bigResult); + mp_clear(&bigRemainder); + mp_clear(&big1); + mp_clear(&big2); + TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); + if (Tcl_IsShared(valuePtr)) { + objResultPtr = Tcl_NewBignumObj(&bigResult); + TRACE(("%s\n", O2S(objResultPtr))); + NEXT_INST_F(1, 2, 1); } + Tcl_SetBignumObj(valuePtr, &bigResult); + TRACE(("%s\n", O2S(valuePtr))); + NEXT_INST_F(1, 1, 0); + } + } + + /* + * Reject negative shift argument. + */ + + switch (type2) { + case TCL_NUMBER_LONG: + invalid = (*((const long *)ptr2) < (long)0); + break; +#ifndef NO_WIDE_TYPE + case TCL_NUMBER_WIDE: + invalid = (*((const Tcl_WideInt *)ptr2) < (Tcl_WideInt)0); + break; +#endif + case TCL_NUMBER_BIG: { + mp_int big2; + 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_SetObjResult(interp, + Tcl_NewStringObj("negative shift argument", -1)); + result = TCL_ERROR; + goto checkForCatch; + } + + /* + * Zero shifted any number of bits is still zero. + */ + + if ((type1==TCL_NUMBER_LONG) && (*((const long *)ptr1) == (long)0)) { + TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); + objResultPtr = constants[0]; + TRACE(("%s\n", O2S(objResultPtr))); + NEXT_INST_F(1, 2, 1); + } + + if (*pc == 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)) { /* - * Too large; need to use the broken-out function. + * 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. */ - TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "integer value too large to represent", -1)); + result = TCL_ERROR; + goto checkForCatch; + } + shift = (int)(*((const long *)ptr2)); + + /* + * Handle shifts within the native long range. + */ + + TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); + if ((type1 == TCL_NUMBER_LONG) + && (size_t) shift < CHAR_BIT*sizeof(long) + && ((l1 = *(const long *)ptr1) != 0) + && !((l1>0 ? l1 : ~l1) + & -(1L<<(CHAR_BIT*sizeof(long) - 1 - shift)))) { + TclNewLongObj(objResultPtr, (l1<<shift)); + TRACE(("%s\n", O2S(objResultPtr))); + NEXT_INST_F(1, 2, 1); + } + + /* + * Handle shifts within the native wide range. + */ + + TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); + if ((type1 != TCL_NUMBER_BIG) + && ((size_t)shift < CHAR_BIT*sizeof(Tcl_WideInt))) { + Tcl_WideInt w; + + TclGetWideIntFromObj(NULL, valuePtr, &w); + if (!((w>0 ? w : ~w) + & -(((Tcl_WideInt)1) + << (CHAR_BIT*sizeof(Tcl_WideInt) - 1 - shift)))) { + objResultPtr = Tcl_NewWideIntObj(w<<shift); + TRACE(("%s\n", O2S(objResultPtr))); + NEXT_INST_F(1, 2, 1); + } + } + } else { + /* + * Quickly force large right shifts to 0 or -1. + */ + + TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); + 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. + */ + + int zero; + + 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: { + mp_int big1; + 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) { + objResultPtr = constants[0]; + } else { + TclNewIntObj(objResultPtr, -1); + } + TRACE(("%s\n", O2S(objResultPtr))); + NEXT_INST_F(1, 2, 1); + } + shift = (int)(*(const long *)ptr2); + + /* + * Handle shifts within the native long range. + */ + + if (type1 == TCL_NUMBER_LONG) { + l1 = *((const long *)ptr1); + if ((size_t)shift >= CHAR_BIT*sizeof(long)) { + if (l1 >= (long)0) { + objResultPtr = constants[0]; + } else { + TclNewIntObj(objResultPtr, -1); + } + } else { + TclNewLongObj(objResultPtr, (l1 >> shift)); + } + TRACE(("%s\n", O2S(objResultPtr))); + NEXT_INST_F(1, 2, 1); + } + +#ifndef NO_WIDE_TYPE + /* + * Handle shifts within the native wide range. + */ + + if (type1 == TCL_NUMBER_WIDE) { + Tcl_WideInt w = *(const Tcl_WideInt *)ptr1; + + if ((size_t)shift >= CHAR_BIT*sizeof(Tcl_WideInt)) { + if (w >= (Tcl_WideInt)0) { + objResultPtr = constants[0]; + } else { + TclNewIntObj(objResultPtr, -1); + } + } else { + objResultPtr = Tcl_NewWideIntObj(w >> shift); + } + TRACE(("%s\n", O2S(objResultPtr))); + NEXT_INST_F(1, 2, 1); + } +#endif + } + + { + mp_int big, bigResult, bigRemainder; + + Tcl_TakeBignumFromObj(NULL, valuePtr, &big); + + mp_init(&bigResult); + if (*pc == INST_LSHIFT) { + mp_mul_2d(&big, shift, &bigResult); + } else { + mp_init(&bigRemainder); + mp_div_2d(&big, 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(&big); + + if (!Tcl_IsShared(valuePtr)) { + Tcl_SetBignumObj(valuePtr, &bigResult); + TRACE(("%s\n", O2S(valuePtr))); + NEXT_INST_F(1, 1, 0); + } + objResultPtr = Tcl_NewBignumObj(&bigResult); + } + TRACE(("%s\n", O2S(objResultPtr))); + NEXT_INST_F(1, 2, 1); + } + + case INST_BITOR: + case INST_BITXOR: + case INST_BITAND: { + ClientData ptr1, ptr2; + int type1, type2; + Tcl_Obj *value2Ptr = OBJ_AT_TOS; + Tcl_Obj *valuePtr = OBJ_UNDER_TOS; + + result = GetNumberFromObj(NULL, valuePtr, &ptr1, &type1); + if ((result != TCL_OK) + || (type1 == TCL_NUMBER_NAN) + || (type1 == TCL_NUMBER_DOUBLE)) { + result = TCL_ERROR; + 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; + } + result = GetNumberFromObj(NULL, value2Ptr, &ptr2, &type2); + if ((result != TCL_OK) || (type2 == TCL_NUMBER_NAN) + || (type2 == TCL_NUMBER_DOUBLE)) { + result = TCL_ERROR; + 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; + } + + if ((type1 == TCL_NUMBER_BIG) || (type2 == TCL_NUMBER_BIG)) { + mp_int big1, big2, bigResult, *First, *Second; + int numPos; + + 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 (*pc) { + 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); + TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); + if (Tcl_IsShared(valuePtr)) { + objResultPtr = Tcl_NewBignumObj(&bigResult); + TRACE(("%s\n", O2S(objResultPtr))); + NEXT_INST_F(1, 2, 1); + } + Tcl_SetBignumObj(valuePtr, &bigResult); + TRACE(("%s\n", O2S(valuePtr))); + NEXT_INST_F(1, 1, 0); + } + +#ifndef NO_WIDE_TYPE + if ((type1 == TCL_NUMBER_WIDE) || (type2 == TCL_NUMBER_WIDE)) { + Tcl_WideInt wResult, w1, w2; + + TclGetWideIntFromObj(NULL, valuePtr, &w1); + TclGetWideIntFromObj(NULL, value2Ptr, &w2); + + switch (*pc) { case INST_BITAND: wResult = w1 & w2; - goto wideResultOfArithmetic; + break; case INST_BITOR: wResult = w1 | w2; - goto wideResultOfArithmetic; + break; case INST_BITXOR: wResult = w1 ^ w2; - goto wideResultOfArithmetic; + break; + default: + /* Unused, here to silence compiler warning. */ + wResult = 0; } + + 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); } +#endif + { + long lResult, l1 = *((const long *)ptr1); + long l2 = *((const long *)ptr2); - /* - * 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. - */ + switch (*pc) { + 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; + } - 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_ERROR(interp); - goto gotError; - } else if (objResultPtr == NULL) { - TRACE_APPEND(("%s\n", O2S(valuePtr))); + 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); + } + TclSetLongObj(valuePtr, lResult); + TRACE(("%s\n", O2S(valuePtr))); NEXT_INST_F(1, 1, 0); - } else { - TRACE_APPEND(("%s\n", O2S(objResultPtr))); - NEXT_INST_F(1, 2, 1); } + } case INST_EXPON: case INST_ADD: case INST_SUB: case INST_DIV: - case INST_MULT: - value2Ptr = OBJ_AT_TOS; - valuePtr = OBJ_UNDER_TOS; + case INST_MULT: { + ClientData ptr1, ptr2; + int type1, type2; + Tcl_Obj *value2Ptr = OBJ_AT_TOS; + Tcl_Obj *valuePtr = OBJ_UNDER_TOS; - if ((GetNumberFromObj(NULL, valuePtr, &ptr1, &type1) != TCL_OK) - || IsErroringNaNType(type1)) { + result = GetNumberFromObj(NULL, valuePtr, &ptr1, &type1); + if ((result != TCL_OK) +#ifndef ACCEPT_NAN + || (type1 == TCL_NUMBER_NAN) +#endif + ) { + result = TCL_ERROR; 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; + goto checkForCatch; } #ifdef ACCEPT_NAN @@ -6223,15 +5543,20 @@ TEBCresume( } #endif - if ((GetNumberFromObj(NULL, value2Ptr, &ptr2, &type2) != TCL_OK) - || IsErroringNaNType(type2)) { + result = GetNumberFromObj(NULL, value2Ptr, &ptr2, &type2); + if ((result != TCL_OK) +#ifndef ACCEPT_NAN + || (type2 == TCL_NUMBER_NAN) +#endif + ) { + result = TCL_ERROR; 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; + goto checkForCatch; } #ifdef ACCEPT_NAN @@ -6245,64 +5570,607 @@ TEBCresume( } #endif - /* - * Handle Tcl_WideInt arithmetic as best we can without going out to - * an external function. - */ + if ((type1 == TCL_NUMBER_DOUBLE) || (type2 == TCL_NUMBER_DOUBLE)) { + /* + * At least one of the values is floating-point, so perform + * floating point calculations. + */ - if ((type1 == TCL_NUMBER_INT) && (type2 == TCL_NUMBER_INT)) { - w1 = *((const Tcl_WideInt *)ptr1); - w2 = *((const Tcl_WideInt *)ptr2); + double d1, d2, dResult; + + Tcl_GetDoubleFromObj(NULL, valuePtr, &d1); + Tcl_GetDoubleFromObj(NULL, value2Ptr, &d2); switch (*pc) { case INST_ADD: - wResult = (Tcl_WideInt)((Tcl_WideUInt)w1 + (Tcl_WideUInt)w2); + 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) { + TRACE(("%.6g %.6g => DIVIDE BY ZERO\n", d1, d2)); + goto divideByZero; + } +#endif /* - * Check for overflow. + * 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. */ - if (Overflowing(w1, w2, wResult)) { - goto overflow; + dResult = d1 / d2; + break; + case INST_EXPON: + if (d1==0.0 && d2<0.0) { + TRACE(("%.6g %.6g => EXPONENT OF ZERO\n", d1, d2)); + goto exponOfZero; } - goto wideResultOfArithmetic; + dResult = pow(d1, d2); + break; + default: + /* Unused, here to silence compiler warning. */ + dResult = 0; + } - case INST_SUB: - wResult = (Tcl_WideInt)((Tcl_WideUInt)w1 - (Tcl_WideUInt)w2); - /* - * 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. - */ +#ifndef ACCEPT_NAN + /* + * Check now for IEEE floating-point error. + */ + + if (TclIsNaN(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; + } +#endif + TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); + if (Tcl_IsShared(valuePtr)) { + TclNewDoubleObj(objResultPtr, dResult); + TRACE(("%s\n", O2S(objResultPtr))); + NEXT_INST_F(1, 2, 1); + } + TclSetDoubleObj(valuePtr, dResult); + TRACE(("%s\n", O2S(valuePtr))); + NEXT_INST_F(1, 1, 0); + } + + if ((sizeof(long) >= 2*sizeof(int)) && (*pc == INST_MULT) + && (type1 == TCL_NUMBER_LONG) && (type2 == TCL_NUMBER_LONG)) { + long l1 = *((const long *)ptr1); + long l2 = *((const long *)ptr2); + + if ((l1 <= INT_MAX) && (l1 >= INT_MIN) + && (l2 <= INT_MAX) && (l2 >= INT_MIN)) { + long lResult = l1 * l2; - if (Overflowing(w1, ~w2, wResult)) { - goto overflow; - } - wideResultOfArithmetic: TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); if (Tcl_IsShared(valuePtr)) { - TclNewIntObj(objResultPtr, wResult); + TclNewLongObj(objResultPtr,lResult); TRACE(("%s\n", O2S(objResultPtr))); NEXT_INST_F(1, 2, 1); } - TclSetIntObj(valuePtr, wResult); + TclSetLongObj(valuePtr, lResult); TRACE(("%s\n", O2S(valuePtr))); NEXT_INST_F(1, 1, 0); - break; + } + } + + if ((sizeof(Tcl_WideInt) >= 2*sizeof(long)) && (*pc == INST_MULT) + && (type1 == TCL_NUMBER_LONG) && (type2 == TCL_NUMBER_LONG)) { + Tcl_WideInt w1, w2, wResult; + TclGetWideIntFromObj(NULL, valuePtr, &w1); + TclGetWideIntFromObj(NULL, value2Ptr, &w2); + + wResult = w1 * w2; + + 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); + } + + /* TODO: Attempts to re-use unshared operands on stack. */ + if (*pc == INST_EXPON) { + long l1 = 0, l2 = 0; + int oddExponent = 0, negativeExponent = 0; +#if (LONG_MAX > 0x7fffffff) || !defined(TCL_WIDE_INT_IS_LONG) + Tcl_WideInt w1; +#endif + + if (type2 == TCL_NUMBER_LONG) { + l2 = *((const long *) ptr2); + if (l2 == 0) { + /* + * Anything to the zero power is 1. + */ + + objResultPtr = constants[1]; + NEXT_INST_F(1, 2, 1); + } else if (l2 == 1) { + /* + * Anything to the first power is itself + */ + NEXT_INST_F(1, 1, 0); + } + } + + switch (type2) { + case TCL_NUMBER_LONG: { + negativeExponent = (l2 < 0); + oddExponent = (int) (l2 & 1); + break; + } +#ifndef NO_WIDE_TYPE + case TCL_NUMBER_WIDE: { + Tcl_WideInt w2 = *((const Tcl_WideInt *)ptr2); + + negativeExponent = (w2 < 0); + oddExponent = (int) (w2 & (Tcl_WideInt)1); + break; + } +#endif + case TCL_NUMBER_BIG: { + mp_int big2; + + 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. + */ + + TRACE(("%s %s => EXPONENT OF ZERO\n", O2S(valuePtr), + O2S(value2Ptr))); + goto exponOfZero; + case -1: + if (oddExponent) { + TclNewIntObj(objResultPtr, -1); + } else { + objResultPtr = constants[1]; + } + NEXT_INST_F(1, 2, 1); + case 1: + /* + * 1 to any power is 1. + */ + + objResultPtr = constants[1]; + NEXT_INST_F(1, 2, 1); + } + } + + /* + * Integers with magnitude greater than 1 raise to a negative + * power yield the answer zero (see TIP 123). + */ + + objResultPtr = constants[0]; + NEXT_INST_F(1, 2, 1); + } + + if (type1 == TCL_NUMBER_LONG) { + switch (l1) { + case 0: + /* + * Zero to a positive power is zero. + */ + + objResultPtr = constants[0]; + NEXT_INST_F(1, 2, 1); + case 1: + /* + * 1 to any power is 1. + */ + + objResultPtr = constants[1]; + NEXT_INST_F(1, 2, 1); + case -1: + if (oddExponent) { + TclNewIntObj(objResultPtr, -1); + } else { + objResultPtr = constants[1]; + } + NEXT_INST_F(1, 2, 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_SetObjResult(interp, + Tcl_NewStringObj("exponent too large", -1)); + result = TCL_ERROR; + goto checkForCatch; + } + + if (type1 == TCL_NUMBER_LONG) { + if (l1 == 2) { + /* + * Reduce small powers of 2 to shifts. + */ + + if ((unsigned long) l2 < CHAR_BIT * sizeof(long) - 1) { + TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); + TclNewLongObj(objResultPtr, (1L << l2)); + TRACE(("%s\n", O2S(objResultPtr))); + NEXT_INST_F(1, 2, 1); + } +#if !defined(TCL_WIDE_INT_IS_LONG) + if ((unsigned long)l2 < CHAR_BIT*sizeof(Tcl_WideInt) - 1){ + TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); + objResultPtr = + Tcl_NewWideIntObj(((Tcl_WideInt) 1) << l2); + TRACE(("%s\n", O2S(objResultPtr))); + NEXT_INST_F(1, 2, 1); + } +#endif + goto overflow; + } + if (l1 == -2) { + int signum = oddExponent ? -1 : 1; + + /* + * Reduce small powers of 2 to shifts. + */ + + if ((unsigned long) l2 < CHAR_BIT * sizeof(long) - 1) { + TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); + TclNewLongObj(objResultPtr, signum * (1L << l2)); + TRACE(("%s\n", O2S(objResultPtr))); + NEXT_INST_F(1, 2, 1); + } +#if !defined(TCL_WIDE_INT_IS_LONG) + if ((unsigned long)l2 < CHAR_BIT*sizeof(Tcl_WideInt) - 1){ + TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); + objResultPtr = Tcl_NewWideIntObj( + signum * (((Tcl_WideInt) 1) << l2)); + TRACE(("%s\n", O2S(objResultPtr))); + NEXT_INST_F(1, 2, 1); + } +#endif + goto overflow; + } +#if (LONG_MAX == 0x7fffffff) + if (l2 - 2 < (long)MaxBase32Size + && l1 <= MaxBase32[l2 - 2] + && l1 >= -MaxBase32[l2 - 2]) { + /* + * Small powers of 32-bit integers. + */ + + long 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; + } + 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); + } + Tcl_SetLongObj(valuePtr, lResult); + TRACE(("%s\n", O2S(valuePtr))); + NEXT_INST_F(1, 1, 0); + } + if (l1 - 3 >= 0 && l1 - 2 < (long)Exp32IndexSize + && l2 - 2 < (long)(Exp32ValueSize + MaxBase32Size)) { + + unsigned short 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. + */ + + TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); + if (Tcl_IsShared(valuePtr)) { + TclNewLongObj(objResultPtr, Exp32Value[base]); + TRACE(("%s\n", O2S(objResultPtr))); + NEXT_INST_F(1, 2, 1); + } + Tcl_SetLongObj(valuePtr, Exp32Value[base]); + TRACE(("%s\n", O2S(valuePtr))); + NEXT_INST_F(1, 1, 0); + } + } + if (-l1 - 3 >= 0 && -l1 - 2 < (long)Exp32IndexSize + && l2 - 2 < (long)(Exp32ValueSize + MaxBase32Size)) { + unsigned short base = Exp32Index[-l1 - 3] + + (unsigned short) (l2 - 2 - MaxBase32Size); + if (base < Exp32Index[-l1 - 2]) { + long lResult = (oddExponent) ? + -Exp32Value[base] : Exp32Value[base]; + + /* + * 32-bit number raised to intermediate power, done by + * table lookup. + */ + + 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); + } + Tcl_SetLongObj(valuePtr, lResult); + TRACE(("%s\n", O2S(valuePtr))); + NEXT_INST_F(1, 1, 0); + } + } +#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 overflow; + } + if (l2 - 2 < (long)MaxBase64Size + && w1 <= MaxBase64[l2 - 2] + && w1 >= -MaxBase64[l2 - 2]) { + /* + * Small powers of integers whose result is wide. + */ + + Tcl_WideInt 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; + + } + TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); + objResultPtr = Tcl_NewWideIntObj(wResult); + TRACE(("%s\n", O2S(objResultPtr))); + NEXT_INST_F(1, 2, 1); + } + + /* + * 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)) { + unsigned short 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. + */ + + TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); + if (Tcl_IsShared(valuePtr)) { + objResultPtr = Tcl_NewWideIntObj(Exp64Value[base]); + TRACE(("%s\n", O2S(objResultPtr))); + NEXT_INST_F(1, 2, 1); + } + Tcl_SetWideIntObj(valuePtr, Exp64Value[base]); + TRACE(("%s\n", O2S(valuePtr))); + NEXT_INST_F(1, 1, 0); + } + } + + if (-w1 - 3 >= 0 && -w1 - 2 < (long)Exp64IndexSize + && l2 - 2 < (long)(Exp64ValueSize + MaxBase64Size)) { + unsigned short base = Exp64Index[-w1 - 3] + + (unsigned short) (l2 - 2 - MaxBase64Size); + + if (base < Exp64Index[-w1 - 2]) { + Tcl_WideInt wResult = (oddExponent) ? + -Exp64Value[base] : Exp64Value[base]; + /* + * 64-bit number raised to intermediate power, done by + * table lookup. + */ + + 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); + } + } +#endif + + goto overflow; + } + + if ((*pc != INST_MULT) + && (type1 != TCL_NUMBER_BIG) && (type2 != TCL_NUMBER_BIG)) { + Tcl_WideInt w1, w2, wResult; + + TclGetWideIntFromObj(NULL, valuePtr, &w1); + TclGetWideIntFromObj(NULL, value2Ptr, &w2); + + switch (*pc) { + 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 overflow; + } + } + 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 overflow; + } + } + break; case INST_DIV: if (w2 == 0) { TRACE(("%s %s => DIVIDE BY ZERO\n", O2S(valuePtr), O2S(value2Ptr))); goto divideByZero; - } else if ((w1 == WIDE_MIN) && (w2 == -1)) { - /* - * Can't represent (-WIDE_MIN) as a Tcl_WideInt. - */ + } + /* + * Need a bignum to represent (LLONG_MIN / -1) + */ + + if ((w1 == LLONG_MIN) && (w2 == -1)) { goto overflow; } wResult = w1 / w2; @@ -6317,183 +6185,302 @@ TEBCresume( ((wResult * w2) != w1)) { wResult -= 1; } - goto wideResultOfArithmetic; + break; + default: + /* + * Unused, here to silence compiler warning. + */ - case INST_MULT: - if (((sizeof(Tcl_WideInt) >= 2*sizeof(int)) - && (w1 <= INT_MAX) && (w1 >= INT_MIN) - && (w2 <= INT_MAX) && (w2 >= INT_MIN)) - || ((sizeof(Tcl_WideInt) >= 2*sizeof(short)) - && (w1 <= SHRT_MAX) && (w1 >= SHRT_MIN) - && (w2 <= SHRT_MAX) && (w2 >= SHRT_MIN))) { - wResult = w1 * w2; - goto wideResultOfArithmetic; - } + wResult = 0; } - /* - * Fall through with INST_EXPON, INST_DIV and large multiplies. - */ + 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); } 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_ERROR(interp); - goto gotError; - } else if (objResultPtr == OUT_OF_MEMORY) { - TRACE_APPEND(("OUT OF MEMORY\n")); - goto outOfMemory; - } else if (objResultPtr == NULL) { - TRACE_APPEND(("%s\n", O2S(valuePtr))); + { + mp_int big1, big2, bigResult, bigRemainder; + + TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); + Tcl_TakeBignumFromObj(NULL, valuePtr, &big1); + Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2); + mp_init(&bigResult); + switch (*pc) { + 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)) { + TRACE(("%s %s => DIVIDE BY ZERO\n", O2S(valuePtr), + O2S(value2Ptr))); + mp_clear(&big1); + mp_clear(&big2); + mp_clear(&bigResult); + goto divideByZero; + } + 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; + case INST_EXPON: + if (big2.used > 1) { + Tcl_SetObjResult(interp, + Tcl_NewStringObj("exponent too large", -1)); + mp_clear(&big1); + mp_clear(&big2); + mp_clear(&bigResult); + result = TCL_ERROR; + goto checkForCatch; + } + mp_expt_d(&big1, big2.dp[0], &bigResult); + break; + } + mp_clear(&big1); + mp_clear(&big2); + if (Tcl_IsShared(valuePtr)) { + objResultPtr = Tcl_NewBignumObj(&bigResult); + TRACE(("%s\n", O2S(objResultPtr))); + NEXT_INST_F(1, 2, 1); + } + Tcl_SetBignumObj(valuePtr, &bigResult); + TRACE(("%s\n", O2S(valuePtr))); NEXT_INST_F(1, 1, 0); - } else { - TRACE_APPEND(("%s\n", O2S(objResultPtr))); - NEXT_INST_F(1, 2, 1); } + } case INST_LNOT: { int b; - - valuePtr = OBJ_AT_TOS; + Tcl_Obj *valuePtr = OBJ_AT_TOS; /* 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\" => ERROR: illegal type %s\n", O2S(valuePtr), + result = TclGetBooleanFromObj(NULL, valuePtr, &b); + if (result != 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; + goto checkForCatch; } /* TODO: Consider peephole opt. */ - objResultPtr = TCONST(!b); - TRACE_WITH_OBJ(("%s => ", O2S(valuePtr)), objResultPtr); + objResultPtr = constants[!b]; NEXT_INST_F(1, 1, 1); } - case INST_BITNOT: - valuePtr = OBJ_AT_TOS; - TRACE(("\"%.20s\" => ", O2S(valuePtr))); - if ((GetNumberFromObj(NULL, valuePtr, &ptr1, &type1) != TCL_OK) - || (type1==TCL_NUMBER_NAN) || (type1==TCL_NUMBER_DOUBLE)) { + case INST_BITNOT: { + mp_int big; + ClientData ptr; + int type; + Tcl_Obj *valuePtr = OBJ_AT_TOS; + + result = GetNumberFromObj(NULL, valuePtr, &ptr, &type); + if ((result != TCL_OK) + || (type == TCL_NUMBER_NAN) || (type == TCL_NUMBER_DOUBLE)) { /* * ... ~$NonInteger => raise an error. */ - TRACE_APPEND(("ERROR: illegal type %s\n", + result = TCL_ERROR; + 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; + goto checkForCatch; } - if (type1 == TCL_NUMBER_INT) { - w1 = *((const Tcl_WideInt *) ptr1); + if (type == TCL_NUMBER_LONG) { + long l = *((const long *)ptr); + if (Tcl_IsShared(valuePtr)) { - TclNewIntObj(objResultPtr, ~w1); - TRACE_APPEND(("%s\n", O2S(objResultPtr))); + TclNewLongObj(objResultPtr, ~l); NEXT_INST_F(1, 1, 1); } - TclSetIntObj(valuePtr, ~w1); - TRACE_APPEND(("%s\n", O2S(valuePtr))); + TclSetLongObj(valuePtr, ~l); NEXT_INST_F(1, 0, 0); } - objResultPtr = ExecuteExtendedUnaryMathOp(*pc, valuePtr); - if (objResultPtr != NULL) { - TRACE_APPEND(("%s\n", O2S(objResultPtr))); - NEXT_INST_F(1, 1, 1); - } else { - TRACE_APPEND(("%s\n", O2S(valuePtr))); +#ifndef NO_WIDE_TYPE + if (type == TCL_NUMBER_WIDE) { + Tcl_WideInt w = *((const Tcl_WideInt *)ptr); + + if (Tcl_IsShared(valuePtr)) { + objResultPtr = Tcl_NewWideIntObj(~w); + NEXT_INST_F(1, 1, 1); + } + Tcl_SetWideIntObj(valuePtr, ~w); NEXT_INST_F(1, 0, 0); } +#endif + Tcl_TakeBignumFromObj(NULL, valuePtr, &big); + /* ~a = - a - 1 */ + mp_neg(&big, &big); + mp_sub_d(&big, 1, &big); + if (Tcl_IsShared(valuePtr)) { + objResultPtr = Tcl_NewBignumObj(&big); + NEXT_INST_F(1, 1, 1); + } + Tcl_SetBignumObj(valuePtr, &big); + NEXT_INST_F(1, 0, 0); + } - case INST_UMINUS: - valuePtr = OBJ_AT_TOS; - TRACE(("\"%.20s\" => ", O2S(valuePtr))); - if ((GetNumberFromObj(NULL, valuePtr, &ptr1, &type1) != TCL_OK) - || IsErroringNaNType(type1)) { - TRACE_APPEND(("ERROR: illegal type %s \n", + case INST_UMINUS: { + ClientData ptr; + int type; + Tcl_Obj *valuePtr = OBJ_AT_TOS; + + result = GetNumberFromObj(NULL, valuePtr, &ptr, &type); + if ((result != TCL_OK) +#ifndef ACCEPT_NAN + || (type == TCL_NUMBER_NAN) +#endif + ) { + result = TCL_ERROR; + 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; + goto checkForCatch; } - switch (type1) { - case TCL_NUMBER_NAN: - /* -NaN => NaN */ - TRACE_APPEND(("%s\n", O2S(valuePtr))); + switch (type) { + case TCL_NUMBER_DOUBLE: { + double d; + + if (Tcl_IsShared(valuePtr)) { + TclNewDoubleObj(objResultPtr, -(*((const double *)ptr))); + NEXT_INST_F(1, 1, 1); + } + d = *((const double *)ptr); + TclSetDoubleObj(valuePtr, -d); NEXT_INST_F(1, 0, 0); - break; - case TCL_NUMBER_INT: - w1 = *((const Tcl_WideInt *) ptr1); - if (w1 != WIDE_MIN) { + } + case TCL_NUMBER_LONG: { + long l = *((const long *)ptr); + + if (l != LONG_MIN) { if (Tcl_IsShared(valuePtr)) { - TclNewIntObj(objResultPtr, -w1); - TRACE_APPEND(("%s\n", O2S(objResultPtr))); + TclNewLongObj(objResultPtr, -l); NEXT_INST_F(1, 1, 1); } - TclSetIntObj(valuePtr, -w1); - TRACE_APPEND(("%s\n", O2S(valuePtr))); + TclSetLongObj(valuePtr, -l); NEXT_INST_F(1, 0, 0); } /* FALLTHROUGH */ } - objResultPtr = ExecuteExtendedUnaryMathOp(*pc, valuePtr); - if (objResultPtr != NULL) { - TRACE_APPEND(("%s\n", O2S(objResultPtr))); - NEXT_INST_F(1, 1, 1); - } else { - TRACE_APPEND(("%s\n", O2S(valuePtr))); +#ifndef NO_WIDE_TYPE + case TCL_NUMBER_WIDE: { + Tcl_WideInt w; + + if (type == TCL_NUMBER_LONG) { + w = (Tcl_WideInt)(*((const long *)ptr)); + } else { + w = *((const Tcl_WideInt *)ptr); + } + if (w != LLONG_MIN) { + if (Tcl_IsShared(valuePtr)) { + objResultPtr = Tcl_NewWideIntObj(-w); + NEXT_INST_F(1, 1, 1); + } + Tcl_SetWideIntObj(valuePtr, -w); + NEXT_INST_F(1, 0, 0); + } + /* FALLTHROUGH */ + } +#endif + case TCL_NUMBER_BIG: { + mp_int big; + + switch (type) { +#ifdef NO_WIDE_TYPE + case TCL_NUMBER_LONG: + TclBNInitBignumFromLong(&big, *(const long *) ptr); + break; +#else + case TCL_NUMBER_WIDE: + TclBNInitBignumFromWideInt(&big, *(const Tcl_WideInt *) ptr); + break; +#endif + case TCL_NUMBER_BIG: + Tcl_TakeBignumFromObj(NULL, valuePtr, &big); + } + mp_neg(&big, &big); + if (Tcl_IsShared(valuePtr)) { + objResultPtr = Tcl_NewBignumObj(&big); + NEXT_INST_F(1, 1, 1); + } + Tcl_SetBignumObj(valuePtr, &big); NEXT_INST_F(1, 0, 0); } + case TCL_NUMBER_NAN: + /* -NaN => NaN */ + NEXT_INST_F(1, 0, 0); + } + } case INST_UPLUS: - case INST_TRY_CVT_TO_NUMERIC: + case INST_TRY_CVT_TO_NUMERIC: { /* * 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. */ - valuePtr = OBJ_AT_TOS; - TRACE(("\"%.20s\" => ", O2S(valuePtr))); + ClientData ptr; + int type; + Tcl_Obj *valuePtr = OBJ_AT_TOS; - if (GetNumberFromObj(NULL, valuePtr, &ptr1, &type1) != TCL_OK) { + if (GetNumberFromObj(NULL, valuePtr, &ptr, &type) != TCL_OK) { if (*pc == INST_UPLUS) { /* * ... +$NonNumeric => raise an error. */ - TRACE_APPEND(("ERROR: illegal type %s\n", + result = TCL_ERROR; + 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; + goto checkForCatch; + } else { + /* ... TryConvertToNumeric($NonNumeric) is acceptable */ + TRACE(("\"%.20s\" => not numeric\n", O2S(valuePtr))); + NEXT_INST_F(1, 0, 0); } - - /* ... TryConvertToNumeric($NonNumeric) is acceptable */ - TRACE_APPEND(("not numeric\n")); - NEXT_INST_F(1, 0, 0); } - if (IsErroringNaNType(type1)) { +#ifndef ACCEPT_NAN + if (type == TCL_NUMBER_NAN) { + result = TCL_ERROR; if (*pc == INST_UPLUS) { /* * ... +$NonNumeric => raise an error. */ - TRACE_APPEND(("ERROR: illegal type %s\n", + TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(valuePtr), (valuePtr->typePtr? valuePtr->typePtr->name:"null"))); DECACHE_STACK_INFO(); IllegalExprOperandType(interp, pc, valuePtr); @@ -6503,13 +6490,15 @@ TEBCresume( * Numeric conversion of NaN -> error. */ - TRACE_APPEND(("ERROR: IEEE floating pt error\n")); + TRACE(("\"%.20s\" => IEEE FLOATING PT ERROR\n", + O2S(objResultPtr))); DECACHE_STACK_INFO(); - TclExprFloatError(interp, *((const double *) ptr1)); + TclExprFloatError(interp, *((const double *)ptr)); CACHE_STACK_INFO(); } - goto gotError; + goto checkForCatch; } +#endif /* * Ensure that the numeric value has a string rep the same as the @@ -6521,13 +6510,13 @@ TEBCresume( */ if (valuePtr->bytes == NULL) { - TRACE_APPEND(("numeric, same Tcl_Obj\n")); + TRACE(("\"%.20s\" => numeric, same Tcl_Obj\n", O2S(valuePtr))); NEXT_INST_F(1, 0, 0); } if (Tcl_IsShared(valuePtr)) { /* * Here we do some surgery within the Tcl_Obj internals. We want - * to copy the internalrep, but not the string, so we temporarily hide + * to copy the intrep, but not the string, so we temporarily hide * the string so we do not copy it. */ @@ -6536,31 +6525,13 @@ TEBCresume( valuePtr->bytes = NULL; objResultPtr = Tcl_DuplicateObj(valuePtr); valuePtr->bytes = savedString; - TRACE_APPEND(("numeric, new Tcl_Obj\n")); + TRACE(("\"%.20s\" => numeric, new Tcl_Obj\n", O2S(valuePtr))); NEXT_INST_F(1, 1, 1); } TclInvalidateStringRep(valuePtr); - TRACE_APPEND(("numeric, same Tcl_Obj\n")); + TRACE(("\"%.20s\" => numeric, same Tcl_Obj\n", O2S(valuePtr))); NEXT_INST_F(1, 0, 0); } - break; - - /* - * End of numeric operator instructions. - * ----------------------------------------------------------------- - */ - - case INST_TRY_CVT_TO_BOOLEAN: - valuePtr = OBJ_AT_TOS; - if (TclHasInternalRep(valuePtr, &tclBooleanType)) { - objResultPtr = TCONST(1); - } else { - int res = (TclSetBooleanFromAny(NULL, valuePtr) == TCL_OK); - objResultPtr = TCONST(res); - } - TRACE_WITH_OBJ(("\"%.30s\" => ", O2S(valuePtr)), objResultPtr); - NEXT_INST_F(1, 0, 1); - break; case INST_BREAK: /* @@ -6570,7 +6541,6 @@ TEBCresume( */ result = TCL_BREAK; cleanup = 0; - TRACE(("=> BREAK!\n")); goto processExceptionReturn; case INST_CONTINUE: @@ -6581,36 +6551,30 @@ TEBCresume( */ result = TCL_CONTINUE; cleanup = 0; - TRACE(("=> CONTINUE!\n")); goto processExceptionReturn; - { - ForeachInfo *infoPtr; - Var *iterVarPtr, *listVarPtr; - Tcl_Obj *oldValuePtr, *listPtr, **elements; - ForeachVarList *varListPtr; - int numLists, listTmpIndex, listLen, numVars; - size_t iterNum; - int varIndex, valIndex, continueLoop, j, iterTmpIndex; - long i; - - case INST_FOREACH_START4: /* DEPRECATED */ + case INST_FOREACH_START4: { /* * Initialize the temporary local var that holds the count of the * number of iterations of the loop body to -1. */ + int opnd, iterTmpIndex; + ForeachInfo *infoPtr; + Var *iterVarPtr; + Tcl_Obj *oldValuePtr; + opnd = TclGetUInt4AtPtr(pc+1); - infoPtr = (ForeachInfo *)codePtr->auxDataArrayPtr[opnd].clientData; + infoPtr = (ForeachInfo *) codePtr->auxDataArrayPtr[opnd].clientData; iterTmpIndex = infoPtr->loopCtTemp; - iterVarPtr = LOCAL(iterTmpIndex); + iterVarPtr = &(compiledLocals[iterTmpIndex]); oldValuePtr = iterVarPtr->value.objPtr; if (oldValuePtr == NULL) { - TclNewIntObj(iterVarPtr->value.objPtr, -1); + TclNewLongObj(iterVarPtr->value.objPtr, -1); Tcl_IncrRefCount(iterVarPtr->value.objPtr); } else { - TclSetIntObj(oldValuePtr, -1); + TclSetLongObj(oldValuePtr, -1); } TRACE(("%u => loop iter count temp %d\n", opnd, iterTmpIndex)); @@ -6626,26 +6590,34 @@ TEBCresume( #else NEXT_INST_F(5, 0, 0); #endif + } - case INST_FOREACH_STEP4: /* DEPRECATED */ + 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. */ + ForeachInfo *infoPtr; + ForeachVarList *varListPtr; + Tcl_Obj *listPtr,*valuePtr, *value2Ptr, **elements; + Var *iterVarPtr, *listVarPtr, *varPtr; + int opnd, numLists, iterNum, listTmpIndex, listLen, numVars; + int varIndex, valIndex, continueLoop, j; + long i; + opnd = TclGetUInt4AtPtr(pc+1); - TRACE(("%u => ", opnd)); - infoPtr = (ForeachInfo *)codePtr->auxDataArrayPtr[opnd].clientData; + infoPtr = (ForeachInfo *) codePtr->auxDataArrayPtr[opnd].clientData; numLists = infoPtr->numLists; /* * Increment the temp holding the loop iteration number. */ - iterVarPtr = LOCAL(infoPtr->loopCtTemp); + iterVarPtr = &(compiledLocals[infoPtr->loopCtTemp]); valuePtr = iterVarPtr->value.objPtr; - iterNum = (size_t)valuePtr->internalRep.wideValue + 1; - TclSetIntObj(valuePtr, iterNum); + iterNum = (valuePtr->internalRep.longValue + 1); + TclSetLongObj(valuePtr, iterNum); /* * Check whether all value lists are exhausted and we should stop the @@ -6658,17 +6630,19 @@ TEBCresume( varListPtr = infoPtr->varLists[i]; numVars = varListPtr->numVars; - listVarPtr = LOCAL(listTmpIndex); + listVarPtr = &(compiledLocals[listTmpIndex]); listPtr = listVarPtr->value.objPtr; - if (TclListObjLength(interp, listPtr, &listLen) != TCL_OK) { - TRACE_APPEND(("ERROR converting list %ld, \"%.30s\": %s\n", - i, O2S(listPtr), O2S(Tcl_GetObjResult(interp)))); - goto gotError; - } - if ((size_t)listLen > iterNum * numVars) { - continueLoop = 1; + result = TclListObjLength(interp, listPtr, &listLen); + if (result == TCL_OK) { + if (listLen > (iterNum * numVars)) { + continueLoop = 1; + } + listTmpIndex++; + } else { + TRACE_WITH_OBJ(("%u => ERROR converting list %ld, \"%s\": ", + opnd, i, O2S(listPtr)), Tcl_GetObjResult(interp)); + goto checkForCatch; } - listTmpIndex++; } /* @@ -6686,9 +6660,8 @@ TEBCresume( varListPtr = infoPtr->varLists[i]; numVars = varListPtr->numVars; - listVarPtr = LOCAL(listTmpIndex); - /* Do not use TclListObjCopy here - shimmers arithseries to list */ - listPtr = Tcl_DuplicateObj(listVarPtr->value.objPtr); + listVarPtr = &(compiledLocals[listTmpIndex]); + listPtr = TclListObjCopy(NULL, listVarPtr->value.objPtr); TclListObjGetElements(interp, listPtr, &listLen, &elements); valIndex = (iterNum * numVars); @@ -6700,7 +6673,7 @@ TEBCresume( } varIndex = varListPtr->varIndexes[j]; - varPtr = LOCAL(varIndex); + varPtr = &(compiledLocals[varIndex]); while (TclIsVarLink(varPtr)) { varPtr = varPtr->value.linkPtr; } @@ -6715,16 +6688,17 @@ TEBCresume( } } else { DECACHE_STACK_INFO(); - if (TclPtrSetVarIdx(interp, varPtr, NULL, NULL, NULL, - valuePtr, TCL_LEAVE_ERR_MSG, varIndex)==NULL){ - CACHE_STACK_INFO(); - TRACE_APPEND(( - "ERROR init. index temp %d: %s\n", - varIndex, O2S(Tcl_GetObjResult(interp)))); + value2Ptr = TclPtrSetVar(interp, varPtr, NULL, NULL, + NULL, valuePtr, TCL_LEAVE_ERR_MSG, varIndex); + CACHE_STACK_INFO(); + if (value2Ptr == NULL) { + TRACE_WITH_OBJ(( + "%u => ERROR init. index temp %d: ", + opnd,varIndex), Tcl_GetObjResult(interp)); + result = TCL_ERROR; TclDecrRefCount(listPtr); - goto gotError; + goto checkForCatch; } - CACHE_STACK_INFO(); } valIndex++; } @@ -6732,8 +6706,8 @@ TEBCresume( listTmpIndex++; } } - TRACE_APPEND(("%d lists, iter %" TCL_Z_MODIFIER "u, %s loop\n", - 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 @@ -6747,232 +6721,7 @@ TEBCresume( } else { NEXT_INST_F((continueLoop? 5 : TclGetInt4AtPtr(pc+1)), 0, 0); } - - } - { - ForeachInfo *infoPtr; - Tcl_Obj *listPtr, **elements; - ForeachVarList *varListPtr; - Tcl_Size numLists, listLen, numVars, listTmpDepth; - size_t iterNum, iterMax, iterTmp; - int varIndex, valIndex, j; - long i; - - case INST_FOREACH_START: - /* - * Initialize the data for the looping construct, pushing the - * corresponding Tcl_Objs to the stack. - */ - - opnd = TclGetUInt4AtPtr(pc+1); - infoPtr = (ForeachInfo *)codePtr->auxDataArrayPtr[opnd].clientData; - numLists = infoPtr->numLists; - TRACE(("%u => ", opnd)); - - /* - * Compute the number of iterations that will be run: iterMax - */ - - iterMax = 0; - listTmpDepth = numLists-1; - for (i = 0; i < numLists; i++) { - varListPtr = infoPtr->varLists[i]; - numVars = varListPtr->numVars; - listPtr = OBJ_AT_DEPTH(listTmpDepth); - if (TclListObjLength(interp, listPtr, &listLen) != TCL_OK) { - TRACE_APPEND(("ERROR converting list %ld, \"%s\": %s", - i, O2S(listPtr), O2S(Tcl_GetObjResult(interp)))); - goto gotError; - } - if (Tcl_IsShared(listPtr)) { - /* Do not use TclListObjCopy here - shimmers arithseries to list */ - objPtr = Tcl_DuplicateObj(listPtr); - if (!objPtr) { - goto gotError; - } - Tcl_IncrRefCount(objPtr); - Tcl_DecrRefCount(listPtr); - OBJ_AT_DEPTH(listTmpDepth) = objPtr; - } - iterTmp = (listLen + (numVars - 1))/numVars; - if (iterTmp > iterMax) { - iterMax = iterTmp; - } - listTmpDepth--; - } - - /* - * Store the iterNum and iterMax in a single Tcl_Obj; we keep a - * nul-string obj with the pointer stored in the ptrValue so that the - * thing is properly garbage collected. THIS OBJ MAKES NO SENSE, but - * it will never leave this scope and is read-only. - */ - - TclNewObj(tmpPtr); - tmpPtr->internalRep.twoPtrValue.ptr1 = NULL; - tmpPtr->internalRep.twoPtrValue.ptr2 = (void *)iterMax; - PUSH_OBJECT(tmpPtr); /* iterCounts object */ - - /* - * Store a pointer to the ForeachInfo struct; same dirty trick - * as above - */ - - TclNewObj(tmpPtr); - tmpPtr->internalRep.twoPtrValue.ptr1 = infoPtr; - PUSH_OBJECT(tmpPtr); /* infoPtr object */ - TRACE_APPEND(("jump to loop step\n")); - - /* - * Jump directly to the INST_FOREACH_STEP instruction; the C code just - * falls through. - */ - - pc += 5 - infoPtr->loopCtTemp; - - case INST_FOREACH_STEP: - /* - * "Step" a foreach loop (i.e., begin its next iteration) by assigning - * the next value list element to each loop var. - */ - - tmpPtr = OBJ_AT_TOS; - infoPtr = (ForeachInfo *)tmpPtr->internalRep.twoPtrValue.ptr1; - numLists = infoPtr->numLists; - TRACE(("=> ")); - - tmpPtr = OBJ_AT_DEPTH(1); - iterNum = (size_t)tmpPtr->internalRep.twoPtrValue.ptr1; - iterMax = (size_t)tmpPtr->internalRep.twoPtrValue.ptr2; - - /* - * If some list still has a remaining list element iterate one more - * time. Assign to var the next element from its value list. - */ - - if (iterNum < iterMax) { - int status; - /* - * Set the variables and jump back to run the body - */ - - tmpPtr->internalRep.twoPtrValue.ptr1 =(void *)(iterNum + 1); - - listTmpDepth = numLists + 1; - - for (i = 0; i < numLists; i++) { - varListPtr = infoPtr->varLists[i]; - numVars = varListPtr->numVars; - int hasAbstractList; - - listPtr = OBJ_AT_DEPTH(listTmpDepth); - hasAbstractList = - TclHasInternalRep(listPtr, &tclArithSeriesType); - DECACHE_STACK_INFO(); - if (hasAbstractList) { - status = Tcl_ListObjLength(interp, listPtr, &listLen); - elements = NULL; - } else { - status = TclListObjGetElements( - interp, listPtr, &listLen, &elements); - } - if (status != TCL_OK) { - CACHE_STACK_INFO(); - goto gotError; - } - CACHE_STACK_INFO(); - - valIndex = (iterNum * numVars); - for (j = 0; j < numVars; j++) { - if (valIndex >= listLen) { - TclNewObj(valuePtr); - } else { - if (elements) { - valuePtr = elements[valIndex]; - } else { - DECACHE_STACK_INFO(); - valuePtr = TclArithSeriesObjIndex( - NULL, listPtr, valIndex); - if (valuePtr == NULL) { - TclNewObj(valuePtr); - } - CACHE_STACK_INFO(); - } - } - - 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); - } - varPtr->value.objPtr = valuePtr; - Tcl_IncrRefCount(valuePtr); - } - } else { - DECACHE_STACK_INFO(); - if (TclPtrSetVarIdx(interp, varPtr, NULL, NULL, NULL, - valuePtr, TCL_LEAVE_ERR_MSG, varIndex)==NULL){ - CACHE_STACK_INFO(); - TRACE_APPEND(("ERROR init. index temp %" TCL_SIZE_MODIFIER "d: %.30s", - varIndex, O2S(Tcl_GetObjResult(interp)))); - goto gotError; - } - CACHE_STACK_INFO(); - } - valIndex++; - } - listTmpDepth--; - } - TRACE_APPEND(("jump to loop start\n")); - /* loopCtTemp being 'misused' for storing the jump size */ - NEXT_INST_F(infoPtr->loopCtTemp, 0, 0); - } - - TRACE_APPEND(("loop has no more iterations\n")); -#ifdef TCL_COMPILE_DEBUG - NEXT_INST_F(1, 0, 0); -#else - /* - * FALL THROUGH - */ - pc++; -#endif - - case INST_FOREACH_END: - /* THIS INSTRUCTION IS ONLY CALLED AS A BREAK TARGET */ - tmpPtr = OBJ_AT_TOS; - infoPtr = (ForeachInfo *)tmpPtr->internalRep.twoPtrValue.ptr1; - numLists = infoPtr->numLists; - TRACE(("=> loop terminated\n")); - NEXT_INST_V(1, numLists+2, 0); - - case INST_LMAP_COLLECT: - /* - * This instruction is only issued by lmap. The stack is: - * - result - * - infoPtr - * - loop counters - * - valLists - * - collecting obj (unshared) - * The instruction lappends the result to the collecting obj. - */ - - tmpPtr = OBJ_AT_DEPTH(1); - infoPtr = (ForeachInfo *)tmpPtr->internalRep.twoPtrValue.ptr1; - numLists = infoPtr->numLists; - TRACE_APPEND(("=> appending to list at depth %" TCL_SIZE_MODIFIER "d\n", 3 + numLists)); - - objPtr = OBJ_AT_DEPTH(3 + numLists); - Tcl_ListObjAppendElement(NULL, objPtr, OBJ_AT_TOS); - NEXT_INST_F(1, 1, 0); } - break; case INST_BEGIN_CATCH4: /* @@ -6981,12 +6730,11 @@ TEBCresume( * stack. */ - *(++catchTop) = (Tcl_Obj *)INT2PTR(CURR_DEPTH); - TRACE(("%u => catchTop=%" TCL_T_MODIFIER "d, stackTop=%" TCL_T_MODIFIER "d\n", - TclGetUInt4AtPtr(pc+1), (catchTop - initCatchTop - 1), - CURR_DEPTH)); + *(++catchTop) = CURR_DEPTH; + TRACE(("%u => catchTop=%d, stackTop=%d\n", + TclGetUInt4AtPtr(pc+1), (int) (catchTop - initCatchTop - 1), + (int) CURR_DEPTH)); NEXT_INST_F(5, 0, 0); - break; case INST_END_CATCH: catchTop--; @@ -6994,9 +6742,8 @@ TEBCresume( Tcl_ResetResult(interp); CACHE_STACK_INFO(); result = TCL_OK; - TRACE(("=> catchTop=%" TCL_Z_MODIFIER "u\n", (size_t)(catchTop - initCatchTop - 1))); + TRACE(("=> catchTop=%d\n", (int) (catchTop - initCatchTop - 1))); NEXT_INST_F(1, 0, 0); - break; case INST_PUSH_RESULT: objResultPtr = Tcl_GetObjResult(interp); @@ -7005,100 +6752,32 @@ TEBCresume( /* * 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); - break; case INST_PUSH_RETURN_CODE: TclNewIntObj(objResultPtr, result); TRACE(("=> %u\n", result)); NEXT_INST_F(1, 0, 1); - break; 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); - break; - - 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; - } - TRACE(("\"%s\" => jump offset %d\n", O2S(OBJ_AT_TOS), 2*code-1)); - NEXT_INST_F(2*code-1, 1, 0); - } - - /* - * ----------------------------------------------------------------- - * Start of dictionary-related instructions. - */ +/* TODO: normalize "valPtr" to "valuePtr" */ { - int opnd2, allocateDict, done, allocdict; - Tcl_Size i; - Tcl_Obj *dictPtr, *statePtr, *keyPtr, *listPtr, *varNamePtr, *keysPtr; - Tcl_Obj *emptyPtr, **keyPtrPtr; - Tcl_DictSearch *searchPtr; - DictUpdateInfo *duiPtr; - - case INST_DICT_VERIFY: - dictPtr = OBJ_AT_TOS; - TRACE(("\"%.30s\" => ", O2S(dictPtr))); - if (Tcl_DictObjSize(interp, dictPtr, &done) != TCL_OK) { - TRACE_APPEND(("ERROR verifying dictionary nature of \"%.30s\": %s\n", - O2S(dictPtr), O2S(Tcl_GetObjResult(interp)))); - goto gotError; - } - TRACE_APPEND(("OK\n")); - NEXT_INST_F(1, 1, 0); - break; - - case INST_DICT_EXISTS: { - int found; - - opnd = TclGetUInt4AtPtr(pc+1); - TRACE(("%u => ", opnd)); - dictPtr = OBJ_AT_DEPTH(opnd); - if (opnd > 1) { - dictPtr = TclTraceDictPath(NULL, dictPtr, opnd-1, - &OBJ_AT_DEPTH(opnd-1), DICT_PATH_EXISTS); - if (dictPtr == NULL || dictPtr == DICT_PATH_NON_EXISTENT) { - found = 0; - goto afterDictExists; - } - } - if (Tcl_DictObjGet(NULL, dictPtr, OBJ_AT_TOS, - &objResultPtr) == TCL_OK) { - found = (objResultPtr ? 1 : 0); - } else { - found = 0; - } - afterDictExists: - TRACE_APPEND(("%d\n", found)); + int opnd, opnd2, allocateDict; + Tcl_Obj *dictPtr, *valPtr; + Var *varPtr; - /* - * The INST_DICT_EXISTS instruction is usually 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). - */ - - JUMP_PEEPHOLE_V(found, 5, opnd+1); - } case INST_DICT_GET: opnd = TclGetUInt4AtPtr(pc+1); TRACE(("%u => ", opnd)); @@ -7108,59 +6787,32 @@ TEBCresume( &OBJ_AT_DEPTH(opnd-1), DICT_PATH_READ); if (dictPtr == NULL) { TRACE_WITH_OBJ(( - "ERROR tracing dictionary path into \"%.30s\": ", - O2S(OBJ_AT_DEPTH(opnd))), + "%u => ERROR tracing dictionary path into \"%s\": ", + opnd, O2S(OBJ_AT_DEPTH(opnd))), Tcl_GetObjResult(interp)); - goto gotError; + result = TCL_ERROR; + goto checkForCatch; } } - if (Tcl_DictObjGet(interp, dictPtr, OBJ_AT_TOS, - &objResultPtr) != TCL_OK) { - TRACE_APPEND(("ERROR reading leaf dictionary key \"%.30s\": %s", - O2S(dictPtr), O2S(Tcl_GetObjResult(interp)))); - goto gotError; + result = Tcl_DictObjGet(interp, dictPtr, OBJ_AT_TOS, &objResultPtr); + if ((result == TCL_OK) && objResultPtr) { + TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); + NEXT_INST_V(5, opnd+1, 1); } - if (!objResultPtr) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "key \"%s\" not known in dictionary", - TclGetString(OBJ_AT_TOS))); + if (result != TCL_OK) { + TRACE_WITH_OBJ(( + "%u => ERROR reading leaf dictionary key \"%s\": ", + opnd, O2S(dictPtr)), Tcl_GetObjResult(interp)); + } else { DECACHE_STACK_INFO(); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "DICT", - TclGetString(OBJ_AT_TOS), (void *)NULL); + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "key \"", TclGetString(OBJ_AT_TOS), + "\" not known in dictionary", NULL); CACHE_STACK_INFO(); - TRACE_ERROR(interp); - goto gotError; - } - TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); - NEXT_INST_V(5, opnd+1, 1); - case INST_DICT_GET_DEF: - opnd = TclGetUInt4AtPtr(pc+1); - TRACE(("%u => ", opnd)); - dictPtr = OBJ_AT_DEPTH(opnd+1); - if (opnd > 1) { - dictPtr = TclTraceDictPath(interp, dictPtr, opnd-1, - &OBJ_AT_DEPTH(opnd), DICT_PATH_EXISTS); - if (dictPtr == NULL) { - TRACE_WITH_OBJ(( - "ERROR tracing dictionary path into \"%.30s\": ", - O2S(OBJ_AT_DEPTH(opnd+1))), - Tcl_GetObjResult(interp)); - goto gotError; - } else if (dictPtr == DICT_PATH_NON_EXISTENT) { - goto dictGetDefUseDefault; - } - } - if (Tcl_DictObjGet(interp, dictPtr, OBJ_UNDER_TOS, - &objResultPtr) != TCL_OK) { - TRACE_APPEND(("ERROR reading leaf dictionary key \"%.30s\": %s", - O2S(dictPtr), O2S(Tcl_GetObjResult(interp)))); - goto gotError; - } else if (!objResultPtr) { - dictGetDefUseDefault: - objResultPtr = OBJ_AT_TOS; + TRACE_WITH_OBJ(("%u => ERROR ", opnd), Tcl_GetObjResult(interp)); + result = TCL_ERROR; } - TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); - NEXT_INST_V(5, opnd+2, 1); + goto checkForCatch; case INST_DICT_SET: case INST_DICT_UNSET: @@ -7168,7 +6820,7 @@ TEBCresume( opnd = TclGetUInt4AtPtr(pc+1); opnd2 = TclGetUInt4AtPtr(pc+5); - varPtr = LOCAL(opnd2); + varPtr = &(compiledLocals[opnd2]); while (TclIsVarLink(varPtr)) { varPtr = varPtr->value.linkPtr; } @@ -7177,8 +6829,7 @@ TEBCresume( dictPtr = varPtr->value.objPtr; } else { DECACHE_STACK_INFO(); - dictPtr = TclPtrGetVarIdx(interp, varPtr, NULL, NULL, NULL, 0, - opnd2); + dictPtr = TclPtrGetVar(interp, varPtr, NULL,NULL,NULL, 0, opnd2); CACHE_STACK_INFO(); } if (dictPtr == NULL) { @@ -7200,24 +6851,25 @@ TEBCresume( case INST_DICT_INCR_IMM: cleanup = 1; opnd = TclGetInt4AtPtr(pc+1); - result = Tcl_DictObjGet(interp, dictPtr, OBJ_AT_TOS, &valuePtr); + result = Tcl_DictObjGet(interp, dictPtr, OBJ_AT_TOS, &valPtr); if (result != TCL_OK) { break; } - if (valuePtr == NULL) { - Tcl_DictObjPut(NULL, dictPtr, OBJ_AT_TOS, Tcl_NewWideIntObj(opnd)); + if (valPtr == NULL) { + Tcl_DictObjPut(NULL, dictPtr, OBJ_AT_TOS,Tcl_NewIntObj(opnd)); } else { - TclNewIntObj(value2Ptr, opnd); - Tcl_IncrRefCount(value2Ptr); - if (Tcl_IsShared(valuePtr)) { - valuePtr = Tcl_DuplicateObj(valuePtr); - Tcl_DictObjPut(NULL, dictPtr, OBJ_AT_TOS, valuePtr); + Tcl_Obj *incrPtr = Tcl_NewIntObj(opnd); + + Tcl_IncrRefCount(incrPtr); + if (Tcl_IsShared(valPtr)) { + valPtr = Tcl_DuplicateObj(valPtr); + Tcl_DictObjPut(NULL, dictPtr, OBJ_AT_TOS, valPtr); } - result = TclIncrObj(interp, valuePtr, value2Ptr); + result = TclIncrObj(interp, valPtr, incrPtr); if (result == TCL_OK) { TclInvalidateStringRep(dictPtr); } - TclDecrRefCount(value2Ptr); + TclDecrRefCount(incrPtr); } break; case INST_DICT_UNSET: @@ -7234,17 +6886,18 @@ TEBCresume( if (allocateDict) { TclDecrRefCount(dictPtr); } - TRACE_APPEND(("ERROR updating dictionary: %s\n", - O2S(Tcl_GetObjResult(interp)))); + 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_Obj *oldValuePtr = varPtr->value.objPtr; + Tcl_IncrRefCount(dictPtr); - if (value2Ptr != NULL) { - TclDecrRefCount(value2Ptr); + if (oldValuePtr != NULL) { + TclDecrRefCount(oldValuePtr); } varPtr->value.objPtr = dictPtr; } @@ -7252,13 +6905,15 @@ TEBCresume( } else { Tcl_IncrRefCount(dictPtr); DECACHE_STACK_INFO(); - objResultPtr = TclPtrSetVarIdx(interp, varPtr, NULL, NULL, NULL, + objResultPtr = TclPtrSetVar(interp, varPtr, NULL, NULL, NULL, dictPtr, TCL_LEAVE_ERR_MSG, opnd2); CACHE_STACK_INFO(); TclDecrRefCount(dictPtr); if (objResultPtr == NULL) { - TRACE_ERROR(interp); - goto gotError; + TRACE_APPEND(("ERROR: %.30s\n", + O2S(Tcl_GetObjResult(interp)))); + result = TCL_ERROR; + goto checkForCatch; } } #ifndef TCL_COMPILE_DEBUG @@ -7266,13 +6921,14 @@ TEBCresume( NEXT_INST_V(10, cleanup, 0); } #endif - TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr))); + 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); + + varPtr = &(compiledLocals[opnd]); while (TclIsVarLink(varPtr)) { varPtr = varPtr->value.linkPtr; } @@ -7281,8 +6937,7 @@ TEBCresume( dictPtr = varPtr->value.objPtr; } else { DECACHE_STACK_INFO(); - dictPtr = TclPtrGetVarIdx(interp, varPtr, NULL, NULL, NULL, 0, - opnd); + dictPtr = TclPtrGetVar(interp, varPtr, NULL, NULL, NULL, 0, opnd); CACHE_STACK_INFO(); } if (dictPtr == NULL) { @@ -7295,41 +6950,29 @@ TEBCresume( } } - if (Tcl_DictObjGet(interp, dictPtr, OBJ_UNDER_TOS, - &valuePtr) != TCL_OK) { + result = Tcl_DictObjGet(interp, dictPtr, OBJ_UNDER_TOS, &valPtr); + if (result != TCL_OK) { if (allocateDict) { TclDecrRefCount(dictPtr); } - TRACE_ERROR(interp); - goto gotError; + goto checkForCatch; } /* - * Note that a non-existent key results in a NULL valuePtr, which is a + * Note that a non-existent key results in a NULL valPtr, 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); + if (valPtr == NULL) { + valPtr = OBJ_AT_TOS; } 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); + if (Tcl_IsShared(valPtr)) { + valPtr = Tcl_DuplicateObj(valPtr); + } + Tcl_AppendObjToObj(valPtr, OBJ_AT_TOS); } break; case INST_DICT_LAPPEND: @@ -7337,53 +6980,41 @@ TEBCresume( * 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 (valPtr == NULL) { + valPtr = Tcl_NewListObj(1, &OBJ_AT_TOS); + } else if (Tcl_IsShared(valPtr)) { + valPtr = Tcl_DuplicateObj(valPtr); + result = Tcl_ListObjAppendElement(interp, valPtr, OBJ_AT_TOS); + if (result != TCL_OK) { + TclDecrRefCount(valPtr); if (allocateDict) { TclDecrRefCount(dictPtr); } - TRACE_ERROR(interp); - goto gotError; + goto checkForCatch; } - Tcl_DictObjPut(NULL, dictPtr, OBJ_UNDER_TOS, valuePtr); } else { - if (Tcl_ListObjAppendElement(interp, valuePtr, - OBJ_AT_TOS) != TCL_OK) { + result = Tcl_ListObjAppendElement(interp, valPtr, OBJ_AT_TOS); + if (result != TCL_OK) { if (allocateDict) { TclDecrRefCount(dictPtr); } - TRACE_ERROR(interp); - goto gotError; + goto checkForCatch; } - - /* - * 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!"); } + Tcl_DictObjPut(NULL, dictPtr, OBJ_UNDER_TOS, valPtr); + if (TclIsVarDirectWritable(varPtr)) { if (allocateDict) { - value2Ptr = varPtr->value.objPtr; + Tcl_Obj *oldValuePtr = varPtr->value.objPtr; + Tcl_IncrRefCount(dictPtr); - if (value2Ptr != NULL) { - TclDecrRefCount(value2Ptr); + if (oldValuePtr != NULL) { + TclDecrRefCount(oldValuePtr); } varPtr->value.objPtr = dictPtr; } @@ -7391,13 +7022,15 @@ TEBCresume( } else { Tcl_IncrRefCount(dictPtr); DECACHE_STACK_INFO(); - objResultPtr = TclPtrSetVarIdx(interp, varPtr, NULL, NULL, NULL, + objResultPtr = TclPtrSetVar(interp, varPtr, NULL, NULL, NULL, dictPtr, TCL_LEAVE_ERR_MSG, opnd); CACHE_STACK_INFO(); TclDecrRefCount(dictPtr); if (objResultPtr == NULL) { - TRACE_ERROR(interp); - goto gotError; + TRACE_APPEND(("ERROR: %.30s\n", + O2S(Tcl_GetObjResult(interp)))); + result = TCL_ERROR; + goto checkForCatch; } } #ifndef TCL_COMPILE_DEBUG @@ -7407,39 +7040,36 @@ TEBCresume( #endif TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); NEXT_INST_F(5, 2, 1); + } + + { + int opnd, done; + Tcl_Obj *statePtr, *dictPtr, *keyPtr, *valuePtr, *emptyPtr; + Var *varPtr; + Tcl_DictSearch *searchPtr; case INST_DICT_FIRST: opnd = TclGetUInt4AtPtr(pc+1); TRACE(("%u => ", opnd)); dictPtr = POP_OBJECT(); - searchPtr = (Tcl_DictSearch *)ckalloc(sizeof(Tcl_DictSearch)); - if (Tcl_DictObjFirst(interp, dictPtr, searchPtr, &keyPtr, - &valuePtr, &done) != TCL_OK) { - - /* - * dictPtr is no longer on the stack, and we're not - * moving it into the internalrep of an iterator. We need - * to drop the refcount [Tcl Bug 9b352768e6]. - */ - - Tcl_DecrRefCount(dictPtr); - ckfree(searchPtr); - TRACE_ERROR(interp); - goto gotError; - } - { - Tcl_ObjInternalRep ir; - TclNewObj(statePtr); - ir.twoPtrValue.ptr1 = searchPtr; - ir.twoPtrValue.ptr2 = dictPtr; - Tcl_StoreInternalRep(statePtr, &dictIteratorType, &ir); + searchPtr = (Tcl_DictSearch *) ckalloc(sizeof(Tcl_DictSearch)); + result = Tcl_DictObjFirst(interp, dictPtr, searchPtr, &keyPtr, + &valuePtr, &done); + if (result != TCL_OK) { + ckfree((char *) searchPtr); + goto checkForCatch; } - varPtr = LOCAL(opnd); + TclNewObj(statePtr); + statePtr->typePtr = &dictIteratorType; + statePtr->internalRep.twoPtrValue.ptr1 = (void *) searchPtr; + statePtr->internalRep.twoPtrValue.ptr2 = (void *) dictPtr; + varPtr = (compiledLocals + opnd); if (varPtr->value.objPtr) { - if (TclHasInternalRep(varPtr->value.objPtr, &dictIteratorType)) { + if (varPtr->value.objPtr->typePtr != &dictIteratorType) { + TclDecrRefCount(varPtr->value.objPtr); + } else { Tcl_Panic("mis-issued dictFirst!"); } - TclDecrRefCount(varPtr->value.objPtr); } varPtr->value.objPtr = statePtr; Tcl_IncrRefCount(statePtr); @@ -7448,18 +7078,12 @@ TEBCresume( case INST_DICT_NEXT: opnd = TclGetUInt4AtPtr(pc+1); TRACE(("%u => ", opnd)); - statePtr = (*LOCAL(opnd)).value.objPtr; - { - const Tcl_ObjInternalRep *irPtr; - - if (statePtr && - (irPtr = TclFetchInternalRep(statePtr, &dictIteratorType))) { - searchPtr = (Tcl_DictSearch *)irPtr->twoPtrValue.ptr1; - Tcl_DictObjNext(searchPtr, &keyPtr, &valuePtr, &done); - } else { - Tcl_Panic("mis-issued dictNext!"); - } + statePtr = compiledLocals[opnd].value.objPtr; + if (statePtr == NULL || statePtr->typePtr != &dictIteratorType) { + Tcl_Panic("mis-issued dictNext!"); } + searchPtr = (Tcl_DictSearch *) statePtr->internalRep.twoPtrValue.ptr1; + Tcl_DictObjNext(searchPtr, &keyPtr, &valuePtr, &done); pushDictIteratorResult: if (done) { TclNewObj(emptyPtr); @@ -7469,133 +7093,160 @@ TEBCresume( PUSH_OBJECT(valuePtr); PUSH_OBJECT(keyPtr); } - TRACE_APPEND(("\"%.30s\" \"%.30s\" %d\n", + TRACE_APPEND(("\"%.30s\" \"%.30s\" %d", O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS), done)); + objResultPtr = constants[done]; + /* TODO: consider opt like INST_FOREACH_STEP4 */ + NEXT_INST_F(5, 0, 1); - /* - * The INST_DICT_FIRST and INST_DICT_NEXT instructions 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). - */ + case INST_DICT_DONE: + opnd = TclGetUInt4AtPtr(pc+1); + TRACE(("%u => ", opnd)); + statePtr = compiledLocals[opnd].value.objPtr; + if (statePtr == NULL) { + Tcl_Panic("mis-issued dictDone!"); + } + + if (statePtr->typePtr == &dictIteratorType) { + /* + * First kill the search, and then release the reference to the + * dictionary that we were holding. + */ - JUMP_PEEPHOLE_F(done, 5, 0); + searchPtr = (Tcl_DictSearch *) + statePtr->internalRep.twoPtrValue.ptr1; + Tcl_DictObjDone(searchPtr); + ckfree((char *) searchPtr); + + dictPtr = (Tcl_Obj *) statePtr->internalRep.twoPtrValue.ptr2; + TclDecrRefCount(dictPtr); + + /* + * Set the internal variable to an empty object to signify that we + * don't hold an iterator. + */ + + TclDecrRefCount(statePtr); + TclNewObj(emptyPtr); + compiledLocals[opnd].value.objPtr = emptyPtr; + Tcl_IncrRefCount(emptyPtr); + } + NEXT_INST_F(5, 0, 0); + } + + { + int opnd, opnd2, i, length, allocdict; + Tcl_Obj **keyPtrPtr, *dictPtr; + DictUpdateInfo *duiPtr; + Var *varPtr; case INST_DICT_UPDATE_START: opnd = TclGetUInt4AtPtr(pc+1); opnd2 = TclGetUInt4AtPtr(pc+5); - TRACE(("%u => ", opnd)); - varPtr = LOCAL(opnd); - duiPtr = (DictUpdateInfo *)codePtr->auxDataArrayPtr[opnd2].clientData; + varPtr = &(compiledLocals[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 = TclPtrGetVarIdx(interp, varPtr, NULL, NULL, NULL, + dictPtr = TclPtrGetVar(interp, varPtr, NULL, NULL, NULL, TCL_LEAVE_ERR_MSG, opnd); CACHE_STACK_INFO(); if (dictPtr == NULL) { - TRACE_ERROR(interp); - goto gotError; + goto dictUpdateStartFailed; } } - Tcl_IncrRefCount(dictPtr); if (TclListObjGetElements(interp, OBJ_AT_TOS, &length, &keyPtrPtr) != TCL_OK) { - TRACE_ERROR(interp); - goto gotError; + goto dictUpdateStartFailed; } if (length != duiPtr->length) { Tcl_Panic("dictUpdateStart argument length mismatch"); } for (i=0 ; i<length ; i++) { + Tcl_Obj *valPtr; + if (Tcl_DictObjGet(interp, dictPtr, keyPtrPtr[i], - &valuePtr) != TCL_OK) { - TRACE_ERROR(interp); - Tcl_DecrRefCount(dictPtr); - goto gotError; + &valPtr) != TCL_OK) { + goto dictUpdateStartFailed; } - varPtr = LOCAL(duiPtr->varIndices[i]); + varPtr = &(compiledLocals[duiPtr->varIndices[i]]); while (TclIsVarLink(varPtr)) { varPtr = varPtr->value.linkPtr; } DECACHE_STACK_INFO(); - if (valuePtr == NULL) { + if (valPtr == NULL) { TclObjUnsetVar2(interp, localName(iPtr->varFramePtr, duiPtr->varIndices[i]), NULL, 0); - } else if (TclPtrSetVarIdx(interp, varPtr, NULL, NULL, NULL, - valuePtr, TCL_LEAVE_ERR_MSG, + } else if (TclPtrSetVar(interp, varPtr, NULL, NULL, NULL, + valPtr, TCL_LEAVE_ERR_MSG, duiPtr->varIndices[i]) == NULL) { CACHE_STACK_INFO(); - TRACE_ERROR(interp); - Tcl_DecrRefCount(dictPtr); - goto gotError; + dictUpdateStartFailed: + result = TCL_ERROR; + goto checkForCatch; } CACHE_STACK_INFO(); } - TclDecrRefCount(dictPtr); - TRACE_APPEND(("OK\n")); NEXT_INST_F(9, 0, 0); case INST_DICT_UPDATE_END: opnd = TclGetUInt4AtPtr(pc+1); opnd2 = TclGetUInt4AtPtr(pc+5); - TRACE(("%u => ", opnd)); - varPtr = LOCAL(opnd); - duiPtr = (DictUpdateInfo *)codePtr->auxDataArrayPtr[opnd2].clientData; + varPtr = &(compiledLocals[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 = TclPtrGetVarIdx(interp, varPtr, NULL, NULL, NULL, 0, - opnd); + dictPtr = TclPtrGetVar(interp, varPtr, NULL, NULL, NULL, 0, opnd); CACHE_STACK_INFO(); } if (dictPtr == NULL) { - TRACE_APPEND(("storage was unset\n")); NEXT_INST_F(9, 1, 0); } if (Tcl_DictObjSize(interp, dictPtr, &length) != TCL_OK || TclListObjGetElements(interp, OBJ_AT_TOS, &length, &keyPtrPtr) != TCL_OK) { - TRACE_ERROR(interp); - goto gotError; + result = TCL_ERROR; + goto checkForCatch; } 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]); + Tcl_Obj *valPtr; + Var *var2Ptr; + var2Ptr = &(compiledLocals[duiPtr->varIndices[i]]); while (TclIsVarLink(var2Ptr)) { var2Ptr = var2Ptr->value.linkPtr; } if (TclIsVarDirectReadable(var2Ptr)) { - valuePtr = var2Ptr->value.objPtr; + valPtr = var2Ptr->value.objPtr; } else { DECACHE_STACK_INFO(); - valuePtr = TclPtrGetVarIdx(interp, var2Ptr, NULL, NULL, NULL, - 0, duiPtr->varIndices[i]); + valPtr = TclPtrGetVar(interp, var2Ptr, NULL, NULL, NULL, 0, + duiPtr->varIndices[i]); CACHE_STACK_INFO(); } - if (valuePtr == NULL) { + if (valPtr == NULL) { Tcl_DictObjRemove(interp, dictPtr, keyPtrPtr[i]); - } else if (dictPtr == valuePtr) { + } else if (dictPtr == valPtr) { Tcl_DictObjPut(interp, dictPtr, keyPtrPtr[i], - Tcl_DuplicateObj(valuePtr)); + Tcl_DuplicateObj(valPtr)); } else { - Tcl_DictObjPut(interp, dictPtr, keyPtrPtr[i], valuePtr); + Tcl_DictObjPut(interp, dictPtr, keyPtrPtr[i], valPtr); } } if (TclIsVarDirectWritable(varPtr)) { @@ -7604,134 +7255,52 @@ TEBCresume( varPtr->value.objPtr = dictPtr; } else { DECACHE_STACK_INFO(); - objResultPtr = TclPtrSetVarIdx(interp, varPtr, NULL, NULL, NULL, + objResultPtr = TclPtrSetVar(interp, varPtr, NULL, NULL, NULL, dictPtr, TCL_LEAVE_ERR_MSG, opnd); CACHE_STACK_INFO(); if (objResultPtr == NULL) { if (allocdict) { TclDecrRefCount(dictPtr); } - TRACE_ERROR(interp); - goto gotError; + result = TCL_ERROR; + goto checkForCatch; } } - TRACE_APPEND(("written back\n")); NEXT_INST_F(9, 1, 0); + } - case INST_DICT_EXPAND: - dictPtr = OBJ_UNDER_TOS; - listPtr = OBJ_AT_TOS; - TRACE(("\"%.30s\" \"%.30s\" =>", O2S(dictPtr), O2S(listPtr))); - if (TclListObjGetElements(interp, listPtr, &objc, &objv) != TCL_OK) { - TRACE_ERROR(interp); - goto gotError; - } - objResultPtr = TclDictWithInit(interp, dictPtr, objc, objv); - if (objResultPtr == NULL) { - TRACE_ERROR(interp); - goto gotError; - } - TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr))); - NEXT_INST_F(1, 2, 1); + default: + Tcl_Panic("TclExecuteByteCode: unrecognized opCode %u", *pc); + } /* end of switch on opCode */ - 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_ERROR(interp); - TclDecrRefCount(keysPtr); - goto gotError; - } - varPtr = TclObjLookupVarEx(interp, varNamePtr, NULL, - TCL_LEAVE_ERR_MSG, "set", 1, 1, &arrayPtr); - if (varPtr == NULL) { - TRACE_ERROR(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_ERROR(interp); - goto gotError; - } - TRACE_APPEND(("OK\n")); - NEXT_INST_F(1, 2, 0); + /* + * Division by zero in an expression. Control only reaches this point by + * "goto divideByZero". + */ - 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_ERROR(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_ERROR(interp); - goto gotError; - } - TRACE_APPEND(("OK\n")); - NEXT_INST_F(5, 2, 0); - } - break; + divideByZero: + DECACHE_STACK_INFO(); + Tcl_SetObjResult(interp, Tcl_NewStringObj("divide by zero", -1)); + Tcl_SetErrorCode(interp, "ARITH", "DIVZERO", "divide by zero", NULL); + CACHE_STACK_INFO(); + + result = TCL_ERROR; + goto checkForCatch; /* - * End of dictionary-related instructions. - * ----------------------------------------------------------------- + * Exponentiation of zero by negative number in an expression. Control + * only reaches this point by "goto exponOfZero". */ - case INST_CLOCK_READ: - { /* Read the wall clock */ - Tcl_WideInt wval; - Tcl_Time now; - switch (TclGetUInt1AtPtr(pc+1)) { - case 0: /* clicks */ -#ifdef TCL_WIDE_CLICKS - wval = TclpGetWideClicks(); -#else - wval = (Tcl_WideInt)TclpGetClicks(); -#endif - break; - case 1: /* microseconds */ - Tcl_GetTime(&now); - wval = (Tcl_WideInt)now.sec * 1000000 + now.usec; - break; - case 2: /* milliseconds */ - Tcl_GetTime(&now); - wval = (Tcl_WideInt)now.sec * 1000 + now.usec / 1000; - break; - case 3: /* seconds */ - Tcl_GetTime(&now); - wval = (Tcl_WideInt)now.sec; - break; - default: - Tcl_Panic("clockRead instruction with unknown clock#"); - } - TclNewIntObj(objResultPtr, wval); - TRACE_WITH_OBJ(("=> "), objResultPtr); - NEXT_INST_F(2, 0, 1); - } - break; - - default: - Tcl_Panic("TclNRExecuteByteCode: unrecognized opCode %u", *pc); - } /* end of switch on opCode */ + exponOfZero: + DECACHE_STACK_INFO(); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "exponentiation of zero by negative power", -1)); + Tcl_SetErrorCode(interp, "ARITH", "DOMAIN", + "exponentiation of zero by negative power", NULL); + CACHE_STACK_INFO(); + result = TCL_ERROR; + goto checkForCatch; /* * Block for variables needed to process exception returns. @@ -7743,7 +7312,12 @@ TEBCresume( * range enclosing the pc. Used by various * instructions and processCatch to process * break, continue, and errors. */ + Tcl_Obj *valuePtr; const char *bytes; + int length; +#if TCL_COMPILE_DEBUG + int opnd; +#endif /* * An external evaluation (INST_INVOKE or INST_EVAL) returned @@ -7752,7 +7326,7 @@ TEBCresume( */ processExceptionReturn: -#ifdef TCL_COMPILE_DEBUG +#if TCL_COMPILE_DEBUG switch (*pc) { case INST_INVOKE_STK1: opnd = TclGetUInt1AtPtr(pc+1); @@ -7792,76 +7366,37 @@ TEBCresume( if (result == TCL_BREAK) { result = TCL_OK; pc = (codePtr->codeStart + rangePtr->breakOffset); - TRACE_APPEND(("%s, range at %" TCL_SIZE_MODIFIER "d, new pc %" TCL_SIZE_MODIFIER "d\n", + 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))); + 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)); + NEXT_INST_F(0, 0, 0); } - if (rangePtr->continueOffset == TCL_INDEX_NONE) { - TRACE_APPEND(("%s, loop w/o continue, checking for catch\n", - StringForResultCode(result))); - goto checkForCatch; - } - result = TCL_OK; - pc = (codePtr->codeStart + rangePtr->continueOffset); - TRACE_APPEND(("%s, range at %" TCL_SIZE_MODIFIER "d, new pc %" TCL_SIZE_MODIFIER "d\n", - StringForResultCode(result), - rangePtr->codeOffset, rangePtr->continueOffset)); - NEXT_INST_F(0, 0, 0); - } -#ifdef TCL_COMPILE_DEBUG - if (traceInstructions) { - objPtr = Tcl_GetObjResult(interp); +#if TCL_COMPILE_DEBUG + } else if (traceInstructions) { if ((result != TCL_ERROR) && (result != TCL_RETURN)) { - TRACE_APPEND(("OTHER RETURN CODE %d, result=\"%.30s\"\n ", + Tcl_Obj *objPtr = Tcl_GetObjResult(interp); + TRACE_APPEND(("OTHER RETURN CODE %d, result= \"%s\"\n ", result, O2S(objPtr))); } else { - TRACE_APPEND(("%s, result=\"%.30s\"\n", + Tcl_Obj *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: - Tcl_SetObjResult(interp, Tcl_NewStringObj("divide by zero", -1)); - DECACHE_STACK_INFO(); - Tcl_SetErrorCode(interp, "ARITH", "DIVZERO", "divide by zero", (void *)NULL); - CACHE_STACK_INFO(); - goto gotError; - - outOfMemory: - Tcl_SetObjResult(interp, Tcl_NewStringObj("out of memory", -1)); - DECACHE_STACK_INFO(); - Tcl_SetErrorCode(interp, "ARITH", "OUTOFMEMORY", "out of memory", (void *)NULL); - CACHE_STACK_INFO(); - goto gotError; - - /* - * Exponentiation of zero by negative number in an expression. Control - * only reaches this point by "goto exponOfZero". - */ - - exponOfZero: - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "exponentiation of zero by negative power", -1)); - DECACHE_STACK_INFO(); - Tcl_SetErrorCode(interp, "ARITH", "DOMAIN", - "exponentiation of zero by negative power", (void *)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 @@ -7871,18 +7406,14 @@ TEBCresume( * and return the "exception" code. */ - checkForCatch: - if (iPtr->execEnvPtr->rewind) { - goto abnormalReturn; - } + checkForCatch: if ((result == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) { - const unsigned char *pcBeg; - - bytes = GetSrcInfoForPc(pc, codePtr, &length, &pcBeg, NULL); - DECACHE_STACK_INFO(); - TclLogCommandInfo(interp, codePtr->source, bytes, - bytes ? length : 0, pcBeg, tosPtr); - CACHE_STACK_INFO(); + bytes = GetSrcInfoForPc(pc, codePtr, &length); + if (bytes != NULL) { + DECACHE_STACK_INFO(); + Tcl_LogCommandInfo(interp, codePtr->source, bytes, length); + CACHE_STACK_INFO(); + } } iPtr->flags &= ~ERR_ALREADY_LOGGED; @@ -7891,32 +7422,13 @@ TEBCresume( * INST_BEGIN_CATCH. */ - while (auxObjList) { - if ((catchTop != initCatchTop) - && (PTR2INT(*catchTop) > - PTR2INT(auxObjList->internalRep.twoPtrValue.ptr2))) { - 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. - */ + while ((expandNestList != NULL) && ((catchTop == initCatchTop) || + (*catchTop <= + (ptrdiff_t) expandNestList->internalRep.twoPtrValue.ptr1))) { + Tcl_Obj *objPtr = expandNestList->internalRep.twoPtrValue.ptr2; - 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; + TclDecrRefCount(expandNestList); + expandNestList = objPtr; } /* @@ -7948,7 +7460,7 @@ TEBCresume( /* * 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. + * breakingcompat with previous .tbc compiled scripts. */ #ifdef TCL_COMPILE_DEBUG @@ -7969,16 +7481,16 @@ TEBCresume( */ processCatch: - while (CURR_DEPTH > PTR2INT(*catchTop)) { + while (CURR_DEPTH > *catchTop) { valuePtr = POP_OBJECT(); TclDecrRefCount(valuePtr); } #ifdef TCL_COMPILE_DEBUG if (traceInstructions) { - fprintf(stdout, " ... found catch at %" TCL_SIZE_MODIFIER "d, catchTop=%" TCL_T_MODIFIER "d, " - "unwound to %" TCL_T_MODIFIER "d, new pc %" TCL_SIZE_MODIFIER "d\n", - rangePtr->codeOffset, (catchTop - initCatchTop - 1), - PTR2INT(*catchTop), rangePtr->catchOffset); + 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); } #endif pc = (codePtr->codeStart + rangePtr->catchOffset); @@ -7989,1224 +7501,46 @@ TEBCresume( */ /* - * Done or abnormal return code. Restore the stack to state it had when + * 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(); + while (tosPtr > initTosPtr) { + Tcl_Obj *objPtr = POP_OBJECT(); + + Tcl_DecrRefCount(objPtr); + } /* - * Clear all expansions and same-level NR calls. - * - * Note that expansion markers have a NULL type; avoid removing other - * markers. + * Clear all expansions. */ - while (auxObjList) { - POP_TAUX_OBJ(); - } - while (tosPtr > initTosPtr) { - objPtr = POP_OBJECT(); - Tcl_DecrRefCount(objPtr); - } + while (expandNestList) { + Tcl_Obj *objPtr = expandNestList->internalRep.twoPtrValue.ptr2; + TclDecrRefCount(expandNestList); + expandNestList = objPtr; + } if (tosPtr < initTosPtr) { fprintf(stderr, - "\nTclNRExecuteByteCode: abnormal return at pc %" TCL_T_MODIFIER "d: " - "stack top %" TCL_T_MODIFIER "d < entry stack top %d\n", - (pc - codePtr->codeStart), - CURR_DEPTH, 0); - Tcl_Panic("TclNRExecuteByteCode execution failure: end stack top < start stack top"); + "\nTclExecuteByteCode: abnormal return at pc %u: " + "stack top %d < entry stack top %d\n", + (unsigned)(pc - codePtr->codeStart), + (unsigned) CURR_DEPTH, (unsigned) 0); + Tcl_Panic("TclExecuteByteCode execution failure: end stack top < start stack top"); } - CLANG_ASSERT(bcFramePtr); } - iPtr->cmdFramePtr = bcFramePtr->nextPtr; - TclReleaseByteCode(codePtr); - TclStackFree(interp, TD); /* free my stack */ - - return result; - - /* - * INST_START_CMD failure case removed where it doesn't bother that much - * - * 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. - - * case INST_START_CMD: - */ - - instStartCmdFailed: - { - const char *bytes; - - length = 0; - - if (TclInterpReady(interp) == TCL_ERROR) { - goto gotError; - } - - /* - * 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], bug [fa6bf38d07] - * - * TODO: recompile, search this command and eval a code starting from, - * so that this evaluation does not add a new TEBC instance without - * NRE-trampoline. - */ - - codePtr->flags |= TCL_BYTECODE_RECOMPILE; - bytes = GetSrcInfoForPc(pc, codePtr, &length, NULL, NULL); - opnd = TclGetUInt4AtPtr(pc+1); - pc += (opnd-1); - assert(bytes); - PUSH_OBJECT(Tcl_NewStringObj(bytes, length)); - goto instEvalStk; - } -} - -#undef codePtr -#undef iPtr -#undef bcFramePtr -#undef initCatchTop -#undef initTosPtr -#undef auxObjList -#undef catchTop -#undef TCONST -#undef esPtr - -static int -FinalizeOONext( - void *data[], - Tcl_Interp *interp, - int result) -{ - Interp *iPtr = (Interp *) interp; - CallContext *contextPtr = (CallContext *)data[1]; - /* - * Reset the variable lookup frame. + * Restore the stack to the state it had previous to this bytecode. */ - iPtr->varFramePtr = (CallFrame *)data[0]; - - /* - * Restore the call chain context index as we've finished the inner invoke - * and want to operate in the outer context again. - */ - - contextPtr->index = PTR2INT(data[2]); - contextPtr->skip = PTR2INT(data[3]); - contextPtr->oPtr->flags &= ~FILTER_HANDLING; + TclStackFree(interp, initCatchTop+1); return result; -} - -static int -FinalizeOONextFilter( - void *data[], - Tcl_Interp *interp, - int result) -{ - Interp *iPtr = (Interp *) interp; - CallContext *contextPtr = (CallContext *)data[1]; - - /* - * Reset the variable lookup frame. - */ - - iPtr->varFramePtr = (CallFrame *)data[0]; - - /* - * Restore the call chain context index as we've finished the inner invoke - * and want to operate in the outer context again. - */ - - contextPtr->index = PTR2INT(data[2]); - contextPtr->skip = PTR2INT(data[3]); - contextPtr->oPtr->flags |= FILTER_HANDLING; - return result; -} - -/* - * WidePwrSmallExpon -- - * - * Helper to calculate small powers of integers whose result is wide. - */ -static inline Tcl_WideInt -WidePwrSmallExpon(Tcl_WideInt w1, long exponent) { - - Tcl_WideInt wResult; - - wResult = w1 * w1; /* b**2 */ - switch (exponent) { - case 2: - break; - case 3: - wResult *= w1; /* 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; - } - return wResult; -} -/* - *---------------------------------------------------------------------- - * - * 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. - * - *---------------------------------------------------------------------- - */ - -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 WIDE_RESULT(w) \ - if (Tcl_IsShared(valuePtr)) { \ - return Tcl_NewWideIntObj(w); \ - } else { \ - TclSetIntObj(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; \ - } - - int type1, type2; - void *ptr1, *ptr2; - double d1, d2, dResult; - Tcl_WideInt w1, w2, wResult; - mp_int big1, big2, bigResult, bigRemainder; - Tcl_Obj *objResultPtr; - int invalid, zero; - int shift; - mp_err err; - - (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 */ - - w2 = 0; /* silence gcc warning */ - if (type2 == TCL_NUMBER_INT) { - w2 = *((const Tcl_WideInt *)ptr2); - if (w2 == 0) { - return DIVIDED_BY_ZERO; - } - if ((w2 == 1) || (w2 == -1)) { - /* - * Div. by |1| always yields remainder of 0. - */ - - return constants[0]; - } - } - if (type1 == TCL_NUMBER_INT) { - w1 = *((const Tcl_WideInt *)ptr1); - - if (w1 == 0) { - /* - * 0 % (non-zero) always yields remainder of 0. - */ - - return constants[0]; - } - if (type2 == TCL_NUMBER_INT) { - Tcl_WideInt wQuotient, wRemainder; - w2 = *((const Tcl_WideInt *)ptr2); - wQuotient = w1 / w2; - - /* - * Force Tcl's integer division rules. - * TODO: examine for logic simplification - */ - - if (((wQuotient < 0) - || ((wQuotient == 0) - && ((w1 < 0 && w2 > 0) - || (w1 > 0 && w2 < 0)))) - && (wQuotient * w2 != w1)) { - wQuotient -= 1; - } - wRemainder = (Tcl_WideInt)((Tcl_WideUInt)w1 - - (Tcl_WideUInt)w2*(Tcl_WideUInt)wQuotient); - WIDE_RESULT(wRemainder); - } - - Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2); - - /* TODO: internals intrusion */ - if ((w1 > ((Tcl_WideInt)0)) ^ !mp_isneg(&big2)) { - /* - * Arguments are opposite sign; remainder is sum. - */ - - err = mp_init_i64(&big1, w1); - if (err == MP_OKAY) { - err = mp_add(&big2, &big1, &big2); - mp_clear(&big1); - } - if (err != MP_OKAY) { - return OUT_OF_MEMORY; - } - BIG_RESULT(&big2); - } - - /* - * Arguments are same sign; remainder is first operand. - */ - - mp_clear(&big2); - return NULL; - } - Tcl_GetBignumFromObj(NULL, valuePtr, &big1); - Tcl_GetBignumFromObj(NULL, value2Ptr, &big2); - err = mp_init_multi(&bigResult, &bigRemainder, (void *)NULL); - if (err == MP_OKAY) { - err = mp_div(&big1, &big2, &bigResult, &bigRemainder); - } - if ((err == MP_OKAY) && !mp_iszero(&bigRemainder) && (bigRemainder.sign != big2.sign)) { - /* - * Convert to Tcl's integer division rules. - */ - - if ((mp_sub_d(&bigResult, 1, &bigResult) != MP_OKAY) - || (mp_add(&bigRemainder, &big2, &bigRemainder) != MP_OKAY)) { - return OUT_OF_MEMORY; - } - } - err = mp_copy(&bigRemainder, &bigResult); - mp_clear(&bigRemainder); - mp_clear(&big1); - mp_clear(&big2); - if (err != MP_OKAY) { - return OUT_OF_MEMORY; - } - BIG_RESULT(&bigResult); - - case INST_LSHIFT: - case INST_RSHIFT: { - /* - * Reject negative shift argument. - */ - - switch (type2) { - case TCL_NUMBER_INT: - invalid = (*((const Tcl_WideInt *)ptr2) < 0); - break; - case TCL_NUMBER_BIG: - Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2); - invalid = mp_isneg(&big2); - mp_clear(&big2); - break; - default: - /* Unused, here to silence compiler warning */ - invalid = 0; - } - if (invalid) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "negative shift argument", -1)); - return GENERAL_ARITHMETIC_ERROR; - } - - /* - * Zero shifted any number of bits is still zero. - */ - - if ((type1==TCL_NUMBER_INT) && (*((const Tcl_WideInt *)ptr1) == 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_INT) - || (*((const Tcl_WideInt *)ptr2) > 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_SetObjResult(interp, Tcl_NewStringObj( - "integer value too large to represent", -1)); - return GENERAL_ARITHMETIC_ERROR; - } - shift = (int)(*((const Tcl_WideInt *)ptr2)); - - /* - * Handle shifts within the native wide range. - */ - - if ((type1 == TCL_NUMBER_INT) - && ((size_t)shift < CHAR_BIT*sizeof(Tcl_WideInt))) { - w1 = *((const Tcl_WideInt *)ptr1); - if (!((w1>0 ? w1 : ~w1) - & -(((Tcl_WideUInt)1) - << (CHAR_BIT*sizeof(Tcl_WideInt) - 1 - shift)))) { - WIDE_RESULT((Tcl_WideUInt)w1 << shift); - } - } - } else { - /* - * Quickly force large right shifts to 0 or -1. - */ - - if ((type2 != TCL_NUMBER_INT) - || (*(const Tcl_WideInt *)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_INT: - zero = (*(const Tcl_WideInt *)ptr1 > 0); - break; - case TCL_NUMBER_BIG: - Tcl_TakeBignumFromObj(NULL, valuePtr, &big1); - zero = !mp_isneg(&big1); - mp_clear(&big1); - break; - default: - /* Unused, here to silence compiler warning. */ - zero = 0; - } - if (zero) { - return constants[0]; - } - WIDE_RESULT(-1); - } - shift = (int)(*(const Tcl_WideInt *)ptr2); - - /* - * Handle shifts within the native wide range. - */ - - if (type1 == TCL_NUMBER_INT) { - w1 = *(const Tcl_WideInt *)ptr1; - if ((size_t)shift >= CHAR_BIT*sizeof(Tcl_WideInt)) { - if (w1 >= 0) { - return constants[0]; - } - WIDE_RESULT(-1); - } - WIDE_RESULT(w1 >> shift); - } - } - - Tcl_TakeBignumFromObj(NULL, valuePtr, &big1); - - err = mp_init(&bigResult); - if (err == MP_OKAY) { - if (opcode == INST_LSHIFT) { - err = mp_mul_2d(&big1, shift, &bigResult); - } else { - err = mp_signed_rsh(&big1, shift, &bigResult); - } - } - if (err != MP_OKAY) { - return OUT_OF_MEMORY; - } - mp_clear(&big1); - BIG_RESULT(&bigResult); - } - - case INST_BITOR: - case INST_BITXOR: - case INST_BITAND: - if ((type1 != TCL_NUMBER_INT) || (type2 != TCL_NUMBER_INT)) { - Tcl_TakeBignumFromObj(NULL, valuePtr, &big1); - Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2); - - err = mp_init(&bigResult); - - if (err == MP_OKAY) { - switch (opcode) { - case INST_BITAND: - err = mp_and(&big1, &big2, &bigResult); - break; - - case INST_BITOR: - err = mp_or(&big1, &big2, &bigResult); - break; - - case INST_BITXOR: - err = mp_xor(&big1, &big2, &bigResult); - break; - } - } - if (err != MP_OKAY) { - return OUT_OF_MEMORY; - } - - mp_clear(&big1); - mp_clear(&big2); - BIG_RESULT(&bigResult); - } - - w1 = *((const Tcl_WideInt *)ptr1); - w2 = *((const Tcl_WideInt *)ptr2); - - 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); - - 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; - } - w1 = w2 = 0; /* to silence compiler warning (maybe-uninitialized) */ - if (type2 == TCL_NUMBER_INT) { - w2 = *((const Tcl_WideInt *) ptr2); - if (w2 == 0) { - /* - * Anything to the zero power is 1. - */ - - return constants[1]; - } else if (w2 == 1) { - /* - * Anything to the first power is itself - */ - - return NULL; - } - - negativeExponent = (w2 < 0); - oddExponent = (int)w2 & 1; - } else { - Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2); - negativeExponent = mp_isneg(&big2); - err = mp_mod_2d(&big2, 1, &big2); - oddExponent = (err == MP_OKAY) && !mp_iszero(&big2); - mp_clear(&big2); - } - - if (type1 == TCL_NUMBER_INT) { - w1 = *((const Tcl_WideInt *)ptr1); - - if (negativeExponent) { - switch (w1) { - case 0: - /* - * Zero to a negative power is div by zero error. - */ - - return EXPONENT_OF_ZERO; - case -1: - if (oddExponent) { - WIDE_RESULT(-1); - } - /* fallthrough */ - case 1: - /* - * 1 to any power is 1. - */ - - return constants[1]; - } - } - } - if (negativeExponent) { - - /* - * 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_INT) { - goto overflowExpon; - } - - switch (w1) { - 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]; - } - WIDE_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 Tcl_WideInt type. This means any numeric Tcl_Obj value - * not using TCL_NUMBER_INT type must hold a value larger than we - * accept. - */ - - if (type2 != TCL_NUMBER_INT) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "exponent too large", -1)); - return GENERAL_ARITHMETIC_ERROR; - } - - /* From here (up to overflowExpon) w1 and exponent w2 are wide-int's. */ - assert(type1 == TCL_NUMBER_INT && type2 == TCL_NUMBER_INT); - - if (w1 == 2) { - /* - * Reduce small powers of 2 to shifts. - */ - - if ((Tcl_WideUInt)w2 < (Tcl_WideUInt)CHAR_BIT*sizeof(Tcl_WideInt) - 1) { - WIDE_RESULT(((Tcl_WideInt)1) << (int)w2); - } - goto overflowExpon; - } - if (w1 == -2) { - int signum = oddExponent ? -1 : 1; - - /* - * Reduce small powers of 2 to shifts. - */ - - if ((Tcl_WideUInt)w2 < CHAR_BIT * sizeof(Tcl_WideInt) - 1) { - WIDE_RESULT(signum * (((Tcl_WideInt)1) << (int) w2)); - } - goto overflowExpon; - } - if (w2 - 2 < (long)MaxBase64Size - && w1 <= MaxBase64[w2 - 2] - && w1 >= -MaxBase64[w2 - 2]) { - /* - * Small powers of integers whose result is wide. - */ - wResult = WidePwrSmallExpon(w1, (long)w2); - - 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 - && w2 - 2 < (long)(Exp64ValueSize + MaxBase64Size)) { - base = Exp64Index[w1 - 3] - + (unsigned short) (w2 - 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 - && w2 - 2 < (long)(Exp64ValueSize + MaxBase64Size)) { - base = Exp64Index[-w1 - 3] - + (unsigned short) (w2 - 2 - MaxBase64Size); - if (base < Exp64Index[-w1 - 2]) { - /* - * 64-bit number raised to intermediate power, done by - * table lookup. - */ - - wResult = oddExponent ? -Exp64Value[base] : Exp64Value[base]; - WIDE_RESULT(wResult); - } - } - - overflowExpon: - - if ((TclGetWideIntFromObj(NULL, value2Ptr, &w2) != TCL_OK) - || (value2Ptr->typePtr != &tclIntType) - || (Tcl_WideUInt)w2 >= (1<<28)) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "exponent too large", -1)); - return GENERAL_ARITHMETIC_ERROR; - } - Tcl_TakeBignumFromObj(NULL, valuePtr, &big1); - err = mp_init(&bigResult); - if (err == MP_OKAY) { - err = mp_expt_u32(&big1, (unsigned int)w2, &bigResult); - } - if (err != MP_OKAY) { - return OUT_OF_MEMORY; - } - mp_clear(&big1); - BIG_RESULT(&bigResult); - } - - 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 (isnan(dResult)) { - TclExprFloatError(interp, dResult); - return GENERAL_ARITHMETIC_ERROR; - } -#endif - DOUBLE_RESULT(dResult); - } - if ((type1 == TCL_NUMBER_INT) && (type2 == TCL_NUMBER_INT)) { - w1 = *((const Tcl_WideInt *)ptr1); - w2 = *((const Tcl_WideInt *)ptr2); - - switch (opcode) { - case INST_ADD: - wResult = (Tcl_WideInt)((Tcl_WideUInt)w1 + (Tcl_WideUInt)w2); - if ((type1 == TCL_NUMBER_INT) || (type2 == TCL_NUMBER_INT)) - { - /* - * Check for overflow. - */ - - if (Overflowing(w1, w2, wResult)) { - goto overflowBasic; - } - } - break; - - case INST_SUB: - wResult = (Tcl_WideInt)((Tcl_WideUInt)w1 - (Tcl_WideUInt)w2); - if ((type1 == TCL_NUMBER_INT) || (type2 == TCL_NUMBER_INT)) - { - /* - * 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 ((w1 < INT_MIN) || (w1 > INT_MAX) || (w2 < INT_MIN) || (w2 > INT_MAX)) { - goto overflowBasic; - } - wResult = w1 * w2; - break; - - case INST_DIV: - if (w2 == 0) { - return DIVIDED_BY_ZERO; - } - - /* - * Need a bignum to represent (WIDE_MIN / -1) - */ - - if ((w1 == WIDE_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); - err = mp_init(&bigResult); - if (err == MP_OKAY) { - switch (opcode) { - case INST_ADD: - err = mp_add(&big1, &big2, &bigResult); - break; - case INST_SUB: - err = mp_sub(&big1, &big2, &bigResult); - break; - case INST_MULT: - err = 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; - } - err = mp_init(&bigRemainder); - if (err == MP_OKAY) { - err = mp_div(&big1, &big2, &bigResult, &bigRemainder); - } - /* TODO: internals intrusion */ - if (!mp_iszero(&bigRemainder) - && (bigRemainder.sign != big2.sign)) { - /* - * Convert to Tcl's integer division rules. - */ - - err = mp_sub_d(&bigResult, 1, &bigResult); - if (err == MP_OKAY) { - err = mp_add(&bigRemainder, &big2, &bigRemainder); - } - } - mp_clear(&bigRemainder); - break; - } - } - mp_clear(&big1); - mp_clear(&big2); - BIG_RESULT(&bigResult); - } - - Tcl_Panic("unexpected opcode"); - return NULL; -} - -static Tcl_Obj * -ExecuteExtendedUnaryMathOp( - int opcode, /* What operation to perform. */ - Tcl_Obj *valuePtr) /* The operand on the stack. */ -{ - void *ptr = NULL; - int type; - Tcl_WideInt w; - mp_int big; - Tcl_Obj *objResultPtr; - mp_err err = MP_OKAY; - - (void) GetNumberFromObj(NULL, valuePtr, &ptr, &type); - - switch (opcode) { - case INST_BITNOT: - if (type == TCL_NUMBER_INT) { - w = *((const Tcl_WideInt *) ptr); - WIDE_RESULT(~w); - } - Tcl_TakeBignumFromObj(NULL, valuePtr, &big); - /* ~a = - a - 1 */ - err = mp_neg(&big, &big); - if (err == MP_OKAY) { - err = mp_sub_d(&big, 1, &big); - } - if (err != MP_OKAY) { - return OUT_OF_MEMORY; - } - BIG_RESULT(&big); - case INST_UMINUS: - switch (type) { - case TCL_NUMBER_DOUBLE: - DOUBLE_RESULT(-(*((const double *) ptr))); - case TCL_NUMBER_INT: - w = *((const Tcl_WideInt *) ptr); - if (w != WIDE_MIN) { - WIDE_RESULT(-w); - } - err = mp_init_i64(&big, w); - if (err != MP_OKAY) { - return OUT_OF_MEMORY; - } - break; - default: - Tcl_TakeBignumFromObj(NULL, valuePtr, &big); - } - err = mp_neg(&big, &big); - if (err != MP_OKAY) { - return OUT_OF_MEMORY; - } - BIG_RESULT(&big); - } - - Tcl_Panic("unexpected opcode"); - return NULL; -} -#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 = TCL_NUMBER_NAN, type2 = TCL_NUMBER_NAN, compare; - void *ptr1, *ptr2; - mp_int big1, big2; - double d1, d2, tmp; - Tcl_WideInt w1, w2; - - (void) GetNumberFromObj(NULL, valuePtr, &ptr1, &type1); - (void) GetNumberFromObj(NULL, value2Ptr, &ptr2, &type2); - - switch (type1) { - case TCL_NUMBER_INT: - w1 = *((const Tcl_WideInt *)ptr1); - switch (type2) { - case TCL_NUMBER_INT: - w2 = *((const Tcl_WideInt *)ptr2); - wideCompare: - return (w1 < w2) ? MP_LT : ((w1 > w2) ? MP_GT : MP_EQ); - case TCL_NUMBER_DOUBLE: - d2 = *((const double *)ptr2); - d1 = (double) w1; - - /* - * If the double has a fractional part, or if the Tcl_WideInt can be - * converted to double without loss of precision, then compare as - * doubles. - */ - - if (DBL_MANT_DIG > CHAR_BIT*sizeof(Tcl_WideInt) || w1 == (Tcl_WideInt)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)WIDE_MIN) { - return MP_GT; - } - if (d2 > (double)WIDE_MAX) { - return MP_LT; - } - w2 = (Tcl_WideInt)d2; - goto wideCompare; - case TCL_NUMBER_BIG: - Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2); - if (mp_isneg(&big2)) { - compare = MP_GT; - } else { - compare = MP_LT; - } - mp_clear(&big2); - return compare; - } - break; - - 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_INT: - 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)WIDE_MIN) { - return MP_LT; - } - if (d1 > (double)WIDE_MAX) { - return MP_GT; - } - w1 = (Tcl_WideInt)d1; - goto wideCompare; - case TCL_NUMBER_BIG: - if (isinf(d1)) { - return (d1 > 0.0) ? MP_GT : MP_LT; - } - Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2); - if ((d1 < (double)WIDE_MAX) && (d1 > (double)WIDE_MIN)) { - if (mp_isneg(&big2)) { - compare = MP_GT; - } else { - compare = MP_LT; - } - mp_clear(&big2); - return compare; - } - if (DBL_MANT_DIG > CHAR_BIT*sizeof(Tcl_WideInt) - && modf(d1, &tmp) != 0.0) { - d2 = TclBignumToDouble(&big2); - mp_clear(&big2); - goto doubleCompare; - } - Tcl_InitBignumFromDouble(NULL, d1, &big1); - goto bigCompare; - } - break; - - case TCL_NUMBER_BIG: - Tcl_TakeBignumFromObj(NULL, valuePtr, &big1); - switch (type2) { - case TCL_NUMBER_INT: - compare = mp_cmp_d(&big1, 0); - mp_clear(&big1); - return compare; - case TCL_NUMBER_DOUBLE: - d2 = *((const double *)ptr2); - if (isinf(d2)) { - compare = (d2 > 0.0) ? MP_LT : MP_GT; - mp_clear(&big1); - return compare; - } - if ((d2 < (double)WIDE_MAX) && (d2 > (double)WIDE_MIN)) { - compare = mp_cmp_d(&big1, 0); - mp_clear(&big1); - return compare; - } - if (DBL_MANT_DIG > CHAR_BIT*sizeof(Tcl_WideInt) - && 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; - } - break; - default: - Tcl_Panic("unexpected number type"); - } - return TCL_ERROR; +#undef iPtr } #ifdef TCL_COMPILE_DEBUG @@ -9216,7 +7550,7 @@ TclCompareTwoNumbers( * PrintByteCodeInfo -- * * This procedure prints a summary about a bytecode object to stdout. It - * is called by TclNRExecuteByteCode when starting to execute the bytecode + * is called by TclExecuteByteCode when starting to execute the bytecode * object if tclTraceExec has the value 2 or more. * * Results: @@ -9230,15 +7564,16 @@ TclCompareTwoNumbers( static void PrintByteCodeInfo( - ByteCode *codePtr) /* The bytecode whose summary is printed to + 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 %" TCL_Z_MODIFIER "u, epoch %u, interp 0x%p (epoch %u)\n", - codePtr, (size_t)codePtr->refCount, codePtr->compileEpoch, iPtr, + fprintf(stdout, "\nExecuting ByteCode 0x%p, refCt %u, epoch %u, interp 0x%p (epoch %u)\n", + codePtr, codePtr->refCount, codePtr->compileEpoch, iPtr, iPtr->compileEpoch); + fprintf(stdout, " Source: "); TclPrintSource(stdout, codePtr->source, 60); @@ -9253,13 +7588,13 @@ PrintByteCodeInfo( 0.0); #ifdef TCL_COMPILE_STATS - fprintf(stdout, " Code %lu = header %" TCL_Z_MODIFIER "u+inst %d+litObj %" TCL_Z_MODIFIER "u+exc %" TCL_Z_MODIFIER "u+aux %" TCL_Z_MODIFIER "u+cmdMap %d\n", + fprintf(stdout, " Code %lu = header %lu+inst %d+litObj %lu+exc %lu+aux %lu+cmdMap %d\n", (unsigned long) codePtr->structureSize, - offsetof(ByteCode, localCachePtr), + (unsigned long) (sizeof(ByteCode)-sizeof(size_t)-sizeof(Tcl_Time)), codePtr->numCodeBytes, - codePtr->numLitObjects * sizeof(Tcl_Obj *), - codePtr->numExceptRanges*sizeof(ExceptionRange), - 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) { @@ -9276,7 +7611,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. * @@ -9293,53 +7628,54 @@ PrintByteCodeInfo( #ifdef TCL_COMPILE_DEBUG static void ValidatePcAndStackTop( - ByteCode *codePtr, /* The bytecode whose summary is printed to + register ByteCode *codePtr, /* The bytecode whose summary is printed to * stdout. */ - const unsigned char *pc, /* Points to first byte of a bytecode + unsigned char *pc, /* Points to first byte of a bytecode * instruction. The program counter. */ - size_t 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. */ { - size_t stackUpperBound = codePtr->maxStackDepth; + int stackUpperBound = stackLowerBound + codePtr->maxStackDepth; /* Greatest legal value for stackTop. */ - size_t relativePc = (size_t)(pc - codePtr->codeStart); - size_t codeStart = (size_t)codePtr->codeStart; - size_t codeEnd = (size_t) + unsigned relativePc = (unsigned) (pc - codePtr->codeStart); + unsigned long codeStart = (unsigned long) codePtr->codeStart; + unsigned long codeEnd = (unsigned long) (codePtr->codeStart + codePtr->numCodeBytes); unsigned char opCode = *pc; - if ((PTR2UINT(pc) < codeStart) || (PTR2UINT(pc) > codeEnd)) { - fprintf(stderr, "\nBad instruction pc 0x%p in TclNRExecuteByteCode\n", + if (((unsigned long) pc < codeStart) || ((unsigned long) pc > codeEnd)) { + fprintf(stderr, "\nBad instruction pc 0x%p in TclExecuteByteCode\n", pc); - Tcl_Panic("TclNRExecuteByteCode execution failure: bad pc"); + Tcl_Panic("TclExecuteByteCode execution failure: bad pc"); } if ((unsigned) opCode > LAST_INST_OPCODE) { - fprintf(stderr, "\nBad opcode %d at pc %" TCL_Z_MODIFIER "u in TclNRExecuteByteCode\n", + fprintf(stderr, "\nBad opcode %d at pc %u in TclExecuteByteCode\n", (unsigned) opCode, relativePc); - Tcl_Panic("TclNRExecuteByteCode execution failure: bad opcode"); + Tcl_Panic("TclExecuteByteCode execution failure: bad opcode"); } if (checkStack && - (stackTop > stackUpperBound)) { + ((stackTop < stackLowerBound) || (stackTop > stackUpperBound))) { int numChars; - const char *cmd = GetSrcInfoForPc(pc, codePtr, &numChars, NULL, NULL); + const char *cmd = GetSrcInfoForPc(pc, codePtr, &numChars); - fprintf(stderr, "\nBad stack top %" TCL_Z_MODIFIER "u at pc %" TCL_Z_MODIFIER "u in TclNRExecuteByteCode (min 0, max %" TCL_Z_MODIFIER "u)", - stackTop, relativePc, stackUpperBound); + 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", TclGetString(message)); + fprintf(stderr,"%s\n", Tcl_GetString(message)); Tcl_DecrRefCount(message); } else { fprintf(stderr, "\n"); } - Tcl_Panic("TclNRExecuteByteCode execution failure: bad stack top"); + Tcl_Panic("TclExecuteByteCode execution failure: bad stack top"); } } #endif /* TCL_COMPILE_DEBUG */ @@ -9349,7 +7685,7 @@ ValidatePcAndStackTop( * * IllegalExprOperandType -- * - * Used by TclNRExecuteByteCode to append an error message to the interp + * Used by TclExecuteByteCode to append an error message to the interp * result when an illegal operand type is detected by an expression * instruction. The argument opndPtr holds the operand object in error. * @@ -9366,25 +7702,25 @@ static void IllegalExprOperandType( 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 * with the illegal type. */ { - void *ptr; + ClientData ptr; int type; - const unsigned char opcode = *pc; - const char *description, *op = "unknown"; + unsigned char opcode = *pc; + const char *description, *operator = "unknown"; if (opcode == INST_EXPON) { - op = "**"; + operator = "**"; } else if (opcode <= INST_LNOT) { - op = operatorStrings[opcode - INST_LOR]; + operator = operatorStrings[opcode - INST_LOR]; } if (GetNumberFromObj(NULL, opndPtr, &ptr, &type) != TCL_OK) { - Tcl_Size numBytes; - const char *bytes = TclGetStringFromObj(opndPtr, &numBytes); + int numBytes; + const char *bytes = Tcl_GetStringFromObj(opndPtr, &numBytes); if (numBytes == 0) { description = "empty string"; @@ -9403,15 +7739,14 @@ IllegalExprOperandType( } Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "can't use %s \"%s\" as operand of \"%s\"", description, - TclGetString(opndPtr), op)); - Tcl_SetErrorCode(interp, "ARITH", "DOMAIN", description, (void *)NULL); + "can't use %s as operand of \"%s\"", description, operator)); + Tcl_SetErrorCode(interp, "ARITH", "DOMAIN", description, NULL); } /* *---------------------------------------------------------------------- * - * TclGetSrcInfoForPc, GetSrcInfoForPc, TclGetSourceFromFrame -- + * TclGetSrcInfoForPc, GetSrcInfoForPc, TclGetSrcInfoForCmd -- * * Given a program counter value, finds the closest command in the * bytecode code unit's CmdLocation array and returns information about @@ -9432,30 +7767,16 @@ IllegalExprOperandType( *---------------------------------------------------------------------- */ -Tcl_Obj * -TclGetSourceFromFrame( - CmdFrame *cfPtr, - Tcl_Size objc, - Tcl_Obj *const objv[]) +const char * +TclGetSrcInfoForCmd( + Interp *iPtr, + int *lenPtr) { - if (cfPtr == NULL) { - return Tcl_NewListObj(objc, objv); - } - if (cfPtr->cmdObj == NULL) { - if (cfPtr->cmd == NULL) { - ByteCode *codePtr = (ByteCode *) cfPtr->data.tebc.codePtr; - - cfPtr->cmd = GetSrcInfoForPc((unsigned char *) - cfPtr->data.tebc.pc, codePtr, &cfPtr->len, NULL, NULL); - } - if (cfPtr->cmd) { - cfPtr->cmdObj = Tcl_NewStringObj(cfPtr->cmd, cfPtr->len); - } else { - cfPtr->cmdObj = Tcl_NewListObj(objc, objv); - } - Tcl_IncrRefCount(cfPtr->cmdObj); - } - return cfPtr->cmdObj; + CmdFrame *cfPtr = iPtr->cmdFramePtr; + ByteCode *codePtr = (ByteCode *) cfPtr->data.tebc.codePtr; + + return GetSrcInfoForPc((unsigned char *) cfPtr->data.tebc.pc, + codePtr, lenPtr); } void @@ -9464,16 +7785,13 @@ TclGetSrcInfoForPc( { ByteCode *codePtr = (ByteCode *) cfPtr->data.tebc.codePtr; - assert(cfPtr->type == TCL_LOCATION_BC); - - if (cfPtr->cmd == NULL) { - - cfPtr->cmd = GetSrcInfoForPc( + if (cfPtr->cmd.str.cmd == NULL) { + cfPtr->cmd.str.cmd = GetSrcInfoForPc( (unsigned char *) cfPtr->data.tebc.pc, codePtr, - &cfPtr->len, NULL, NULL); + &cfPtr->cmd.str.len); } - if (cfPtr->cmd != NULL) { + 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. @@ -9481,18 +7799,17 @@ TclGetSrcInfoForPc( ExtCmdLoc *eclPtr; ECL *locPtr = NULL; - Tcl_Size srcOffset; - int i; + int srcOffset, i; Interp *iPtr = (Interp *) *codePtr->interpHandle; Tcl_HashEntry *hePtr = - Tcl_FindHashEntry(iPtr->lineBCPtr, codePtr); + Tcl_FindHashEntry(iPtr->lineBCPtr, (char *) codePtr); if (!hePtr) { return; } - srcOffset = cfPtr->cmd - codePtr->source; - eclPtr = (ExtCmdLoc *)Tcl_GetHashValue(hePtr); + srcOffset = cfPtr->cmd.str.cmd - codePtr->source; + eclPtr = (ExtCmdLoc *) Tcl_GetHashValue (hePtr); for (i=0; i < eclPtr->nuloc; i++) { if (eclPtr->loc[i].srcOffset == srcOffset) { @@ -9522,34 +7839,28 @@ TclGetSrcInfoForPc( static const char * GetSrcInfoForPc( - const unsigned char *pc, /* The program counter value for which to + unsigned char *pc, /* The program counter value for which to * return the closest command's source info. - * This points within a bytecode instruction - * in codePtr's code. */ + * 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. */ - Tcl_Size *lengthPtr, /* If non-NULL, the location where the length + 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. */ - Tcl_Size *cmdIdxPtr) /* If non-NULL, the location where the index - * of the command containing the pc should - * be stored. */ { - Tcl_Size pcOffset = pc - codePtr->codeStart; - Tcl_Size numCmds = codePtr->numCommands; + register int pcOffset = (pc - codePtr->codeStart); + int numCmds = codePtr->numCommands; unsigned char *codeDeltaNext, *codeLengthNext; unsigned char *srcDeltaNext, *srcLengthNext; - Tcl_Size codeOffset, codeLen, codeEnd, srcOffset, srcLen, delta, i; + int codeOffset, codeLen, codeEnd, srcOffset, srcLen, delta, i; int bestDist = INT_MAX; /* Distance of pc to best cmd's start pc. */ - Tcl_Size bestSrcOffset = -1; /* Initialized to avoid compiler warning. */ - Tcl_Size bestSrcLength = -1; /* Initialized to avoid compiler warning. */ - Tcl_Size bestCmdIdx = -1; + int bestSrcOffset = -1; /* Initialized to avoid compiler warning. */ + int bestSrcLength = -1; /* Initialized to avoid compiler warning. */ - /* The pc must point within the bytecode */ - assert ((pcOffset >= 0) && (pcOffset < codePtr->numCodeBytes)); + if ((pcOffset < 0) || (pcOffset >= codePtr->numCodeBytes)) { + return NULL; + } /* * Decode the code and source offset and length for each command. The @@ -9612,28 +7923,10 @@ GetSrcInfoForPc( bestDist = dist; bestSrcOffset = srcOffset; bestSrcLength = srcLen; - bestCmdIdx = i; } } } - 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; } @@ -9641,11 +7934,6 @@ GetSrcInfoForPc( if (lengthPtr != NULL) { *lengthPtr = bestSrcLength; } - - if (cmdIdxPtr != NULL) { - *cmdIdxPtr = bestCmdIdx; - } - return (codePtr->source + bestSrcOffset); } @@ -9676,7 +7964,7 @@ GetSrcInfoForPc( static ExceptionRange * GetExceptRangeForPc( - const unsigned char *pc, /* The program counter value for which to + 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. */ @@ -9691,9 +7979,9 @@ GetExceptRangeForPc( { ExceptionRange *rangeArrayPtr; int numRanges = codePtr->numExceptRanges; - ExceptionRange *rangePtr; + register ExceptionRange *rangePtr; int pcOffset = pc - codePtr->codeStart; - int start; + register int start; if (numRanges == 0) { return NULL; @@ -9717,7 +8005,7 @@ GetExceptRangeForPc( if (searchMode == TCL_BREAK) { return rangePtr; } - if (searchMode == TCL_CONTINUE && rangePtr->continueOffset != TCL_INDEX_NONE){ + if (searchMode == TCL_CONTINUE && rangePtr->continueOffset != -1){ return rangePtr; } } @@ -9731,7 +8019,7 @@ 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 + * in TclExecuteByteCode when debugging. It returns the name of the * bytecode instruction at a specified instruction pc. * * Results: @@ -9744,9 +8032,9 @@ GetExceptRangeForPc( */ #ifdef TCL_COMPILE_DEBUG -static const char * +static char * GetOpcodeName( - const unsigned char *pc) /* Points to the instruction whose name should + unsigned char *pc) /* Points to the instruction whose name should * be returned. */ { unsigned char opCode = *pc; @@ -9780,26 +8068,26 @@ TclExprFloatError( { const char *s; - if ((errno == EDOM) || isnan(value)) { + if ((errno == EDOM) || TclIsNaN(value)) { s = "domain error: argument not in valid range"; Tcl_SetObjResult(interp, Tcl_NewStringObj(s, -1)); - Tcl_SetErrorCode(interp, "ARITH", "DOMAIN", s, (void *)NULL); - } else if ((errno == ERANGE) || isinf(value)) { + Tcl_SetErrorCode(interp, "ARITH", "DOMAIN", s, NULL); + } else if ((errno == ERANGE) || TclIsInfinite(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, (void *)NULL); + Tcl_SetErrorCode(interp, "ARITH", "UNDERFLOW", s, NULL); } else { s = "floating-point value too large to represent"; Tcl_SetObjResult(interp, Tcl_NewStringObj(s, -1)); - Tcl_SetErrorCode(interp, "ARITH", "OVERFLOW", s, (void *)NULL); + Tcl_SetErrorCode(interp, "ARITH", "OVERFLOW", s, NULL); } } else { Tcl_Obj *objPtr = Tcl_ObjPrintf( "unknown floating-point error, errno = %d", errno); Tcl_SetErrorCode(interp, "ARITH", "UNKNOWN", - TclGetString(objPtr), (void *)NULL); + Tcl_GetString(objPtr), NULL); Tcl_SetObjResult(interp, objPtr); } } @@ -9825,11 +8113,11 @@ TclExprFloatError( int TclLog2( - int value) /* The integer for which to compute the log + register int value) /* The integer for which to compute the log * base 2. */ { - int n = value; - int result = 0; + register int n = value; + register int result = 0; while (n > 1) { n = n >> 1; @@ -9857,7 +8145,7 @@ TclLog2( static int EvalStatsCmd( - TCL_UNUSED(void *), /* Unused. */ + ClientData unused, /* Unused. */ Tcl_Interp *interp, /* The current interpreter. */ int objc, /* The number of arguments. */ Tcl_Obj *const objv[]) /* The argument strings. */ @@ -9870,17 +8158,17 @@ EvalStatsCmd( double objBytesIfUnshared, strBytesIfUnshared, sharingBytesSaved; double strBytesSharedMultX, strBytesSharedOnce; double numInstructions, currentHeaderBytes; - size_t numCurrentByteCodes, numByteCodeLits; - size_t refCountSum, literalMgmtBytes, sum; - size_t numSharedMultX, numSharedOnce, minSizeDecade, maxSizeDecade, i; - int decadeHigh, length; + long numCurrentByteCodes, numByteCodeLits; + long refCountSum, literalMgmtBytes, sum; + int numSharedMultX, numSharedOnce; + int decadeHigh, minSizeDecade, maxSizeDecade, length, i; char *litTableStats; LiteralEntry *entryPtr; Tcl_Obj *objPtr; #define Percent(a,b) ((a) * 100.0 / (b)) - TclNewObj(objPtr); + objPtr = Tcl_NewObj(); Tcl_IncrRefCount(objPtr); numInstructions = 0.0; @@ -9900,7 +8188,7 @@ EvalStatsCmd( numCurrentByteCodes = statsPtr->numCompilations - statsPtr->numByteCodesFreed; currentHeaderBytes = numCurrentByteCodes - * offsetof(ByteCode, localCachePtr); + * (sizeof(ByteCode) - sizeof(size_t) - sizeof(Tcl_Time)); literalMgmtBytes = sizeof(LiteralTable) + (iPtr->literalTable.numBuckets * sizeof(LiteralEntry *)) + (iPtr->literalTable.numEntries * sizeof(LiteralEntry)); @@ -9915,63 +8203,63 @@ EvalStatsCmd( Tcl_AppendPrintfToObj(objPtr, "\n----------------------------------------------------------------\n"); Tcl_AppendPrintfToObj(objPtr, - "Compilation and execution statistics for interpreter %p\n", + "Compilation and execution statistics for interpreter %#lx\n", iPtr); - Tcl_AppendPrintfToObj(objPtr, "\nNumber ByteCodes executed\t%" TCL_Z_MODIFIER "u\n", + Tcl_AppendPrintfToObj(objPtr, "\nNumber ByteCodes executed %ld\n", statsPtr->numExecutions); - Tcl_AppendPrintfToObj(objPtr, "Number ByteCodes compiled\t%" TCL_Z_MODIFIER "u\n", + Tcl_AppendPrintfToObj(objPtr, "Number ByteCodes compiled %ld\n", statsPtr->numCompilations); - Tcl_AppendPrintfToObj(objPtr, " Mean executions/compile\t%.1f\n", + Tcl_AppendPrintfToObj(objPtr, " Mean executions/compile %.1f\n", statsPtr->numExecutions / (float)statsPtr->numCompilations); - Tcl_AppendPrintfToObj(objPtr, "\nInstructions executed\t\t%.0f\n", + Tcl_AppendPrintfToObj(objPtr, "\nInstructions executed %.0f\n", numInstructions); - Tcl_AppendPrintfToObj(objPtr, " Mean inst/compile\t\t%.0f\n", + Tcl_AppendPrintfToObj(objPtr, " Mean inst/compile %.0f\n", numInstructions / statsPtr->numCompilations); - Tcl_AppendPrintfToObj(objPtr, " Mean inst/execution\t\t%.0f\n", + Tcl_AppendPrintfToObj(objPtr, " Mean inst/execution %.0f\n", numInstructions / statsPtr->numExecutions); - Tcl_AppendPrintfToObj(objPtr, "\nTotal ByteCodes\t\t\t%" TCL_Z_MODIFIER "u\n", + Tcl_AppendPrintfToObj(objPtr, "\nTotal ByteCodes %ld\n", statsPtr->numCompilations); - Tcl_AppendPrintfToObj(objPtr, " Source bytes\t\t\t%.6g\n", + Tcl_AppendPrintfToObj(objPtr, " Source bytes %.6g\n", statsPtr->totalSrcBytes); - Tcl_AppendPrintfToObj(objPtr, " Code bytes\t\t\t%.6g\n", + Tcl_AppendPrintfToObj(objPtr, " Code bytes %.6g\n", totalCodeBytes); - Tcl_AppendPrintfToObj(objPtr, " ByteCode bytes\t\t%.6g\n", + Tcl_AppendPrintfToObj(objPtr, " ByteCode bytes %.6g\n", statsPtr->totalByteCodeBytes); - Tcl_AppendPrintfToObj(objPtr, " Literal bytes\t\t%.6g\n", + Tcl_AppendPrintfToObj(objPtr, " Literal bytes %.6g\n", totalLiteralBytes); - Tcl_AppendPrintfToObj(objPtr, " table %" TCL_Z_MODIFIER "u + bkts %" TCL_Z_MODIFIER "u + entries %" TCL_Z_MODIFIER "u + objects %" TCL_Z_MODIFIER "u + strings %.6g\n", - sizeof(LiteralTable), - iPtr->literalTable.numBuckets * sizeof(LiteralEntry *), - statsPtr->numLiteralsCreated * sizeof(LiteralEntry), - statsPtr->numLiteralsCreated * sizeof(Tcl_Obj), + 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)), statsPtr->totalLitStringBytes); - Tcl_AppendPrintfToObj(objPtr, " Mean code/compile\t\t%.1f\n", + Tcl_AppendPrintfToObj(objPtr, " Mean code/compile %.1f\n", totalCodeBytes / statsPtr->numCompilations); - Tcl_AppendPrintfToObj(objPtr, " Mean code/source\t\t%.1f\n", + Tcl_AppendPrintfToObj(objPtr, " Mean code/source %.1f\n", totalCodeBytes / statsPtr->totalSrcBytes); - Tcl_AppendPrintfToObj(objPtr, "\nCurrent (active) ByteCodes\t%" TCL_Z_MODIFIER "u\n", + Tcl_AppendPrintfToObj(objPtr, "\nCurrent (active) ByteCodes %ld\n", numCurrentByteCodes); - Tcl_AppendPrintfToObj(objPtr, " Source bytes\t\t\t%.6g\n", + Tcl_AppendPrintfToObj(objPtr, " Source bytes %.6g\n", statsPtr->currentSrcBytes); - Tcl_AppendPrintfToObj(objPtr, " Code bytes\t\t\t%.6g\n", + Tcl_AppendPrintfToObj(objPtr, " Code bytes %.6g\n", currentCodeBytes); - Tcl_AppendPrintfToObj(objPtr, " ByteCode bytes\t\t%.6g\n", + Tcl_AppendPrintfToObj(objPtr, " ByteCode bytes %.6g\n", statsPtr->currentByteCodeBytes); - Tcl_AppendPrintfToObj(objPtr, " Literal bytes\t\t%.6g\n", + Tcl_AppendPrintfToObj(objPtr, " Literal bytes %.6g\n", currentLiteralBytes); - Tcl_AppendPrintfToObj(objPtr, " table %" TCL_Z_MODIFIER "u + bkts %" TCL_Z_MODIFIER "u + entries %" TCL_Z_MODIFIER "u + objects %" TCL_Z_MODIFIER "u + strings %.6g\n", - sizeof(LiteralTable), - iPtr->literalTable.numBuckets * sizeof(LiteralEntry *), - iPtr->literalTable.numEntries * sizeof(LiteralEntry), - iPtr->literalTable.numEntries * sizeof(Tcl_Obj), + 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)), statsPtr->currentLitStringBytes); - Tcl_AppendPrintfToObj(objPtr, " Mean code/source\t\t%.1f\n", + Tcl_AppendPrintfToObj(objPtr, " Mean code/source %.1f\n", currentCodeBytes / statsPtr->currentSrcBytes); - Tcl_AppendPrintfToObj(objPtr, " Code + source bytes\t\t%.6g (%0.1f mean code/src)\n", + Tcl_AppendPrintfToObj(objPtr, " Code + source bytes %.6g (%0.1f mean code/src)\n", (currentCodeBytes + statsPtr->currentSrcBytes), (currentCodeBytes / statsPtr->currentSrcBytes) + 1.0); @@ -9984,17 +8272,17 @@ EvalStatsCmd( numSharedMultX = 0; Tcl_AppendPrintfToObj(objPtr, "\nTcl_IsShared object check (all objects):\n"); - Tcl_AppendPrintfToObj(objPtr, " Object had refcount <=1 (not shared)\t%" TCL_Z_MODIFIER "u\n", + Tcl_AppendPrintfToObj(objPtr, " Object had refcount <=1 (not shared) %ld\n", tclObjsShared[1]); for (i = 2; i < TCL_MAX_SHARED_OBJ_STATS; i++) { - Tcl_AppendPrintfToObj(objPtr, " refcount ==%" TCL_Z_MODIFIER "u\t\t%" TCL_Z_MODIFIER "u\n", + Tcl_AppendPrintfToObj(objPtr, " refcount ==%d %ld\n", i, tclObjsShared[i]); numSharedMultX += tclObjsShared[i]; } - Tcl_AppendPrintfToObj(objPtr, " refcount >=%" TCL_Z_MODIFIER "u\t\t%" TCL_Z_MODIFIER "u\n", + Tcl_AppendPrintfToObj(objPtr, " refcount >=%d %ld\n", i, tclObjsShared[0]); numSharedMultX += tclObjsShared[0]; - Tcl_AppendPrintfToObj(objPtr, " Total shared objects\t\t\t%" TCL_Z_MODIFIER "u\n", + Tcl_AppendPrintfToObj(objPtr, " Total shared objects %d\n", numSharedMultX); /* @@ -10012,10 +8300,10 @@ EvalStatsCmd( for (i = 0; i < globalTablePtr->numBuckets; i++) { for (entryPtr = globalTablePtr->buckets[i]; entryPtr != NULL; entryPtr = entryPtr->nextPtr) { - if (TclHasInternalRep(entryPtr->objPtr, &tclByteCodeType)) { + if (entryPtr->objPtr->typePtr == &tclByteCodeType) { numByteCodeLits++; } - (void) TclGetStringFromObj(entryPtr->objPtr, &length); + (void) Tcl_GetStringFromObj(entryPtr->objPtr, &length); refCountSum += entryPtr->refCount; objBytesIfUnshared += (entryPtr->refCount * sizeof(Tcl_Obj)); strBytesIfUnshared += (entryPtr->refCount * (length+1)); @@ -10031,31 +8319,31 @@ EvalStatsCmd( sharingBytesSaved = (objBytesIfUnshared + strBytesIfUnshared) - currentLiteralBytes; - Tcl_AppendPrintfToObj(objPtr, "\nTotal objects (all interps)\t%" TCL_Z_MODIFIER "u\n", + Tcl_AppendPrintfToObj(objPtr, "\nTotal objects (all interps) %ld\n", tclObjsAlloced); - Tcl_AppendPrintfToObj(objPtr, "Current objects\t\t\t%" TCL_Z_MODIFIER "u\n", + Tcl_AppendPrintfToObj(objPtr, "Current objects %ld\n", (tclObjsAlloced - tclObjsFreed)); - Tcl_AppendPrintfToObj(objPtr, "Total literal objects\t\t%" TCL_Z_MODIFIER "u\n", + Tcl_AppendPrintfToObj(objPtr, "Total literal objects %ld\n", statsPtr->numLiteralsCreated); - Tcl_AppendPrintfToObj(objPtr, "\nCurrent literal objects\t\t%" TCL_SIZE_MODIFIER "d (%0.1f%% of current objects)\n", + Tcl_AppendPrintfToObj(objPtr, "\nCurrent literal objects %d (%0.1f%% of current objects)\n", globalTablePtr->numEntries, Percent(globalTablePtr->numEntries, tclObjsAlloced-tclObjsFreed)); - Tcl_AppendPrintfToObj(objPtr, " ByteCode literals\t\t%" TCL_Z_MODIFIER "u (%0.1f%% of current literals)\n", + Tcl_AppendPrintfToObj(objPtr, " ByteCode literals %ld (%0.1f%% of current literals)\n", numByteCodeLits, Percent(numByteCodeLits, globalTablePtr->numEntries)); - Tcl_AppendPrintfToObj(objPtr, " Literals reused > 1x\t\t%" TCL_Z_MODIFIER "u\n", + Tcl_AppendPrintfToObj(objPtr, " Literals reused > 1x %d\n", numSharedMultX); - Tcl_AppendPrintfToObj(objPtr, " Mean reference count\t\t%.2f\n", + Tcl_AppendPrintfToObj(objPtr, " Mean reference count %.2f\n", ((double) refCountSum) / globalTablePtr->numEntries); - Tcl_AppendPrintfToObj(objPtr, " Mean len, str reused >1x \t%.2f\n", + Tcl_AppendPrintfToObj(objPtr, " Mean len, str reused >1x %.2f\n", (numSharedMultX ? strBytesSharedMultX/numSharedMultX : 0.0)); - Tcl_AppendPrintfToObj(objPtr, " Mean len, str used 1x\t\t%.2f\n", + Tcl_AppendPrintfToObj(objPtr, " Mean len, str used 1x %.2f\n", (numSharedOnce ? strBytesSharedOnce/numSharedOnce : 0.0)); - Tcl_AppendPrintfToObj(objPtr, " Total sharing savings\t\t%.6g (%0.1f%% of bytes if no sharing)\n", + Tcl_AppendPrintfToObj(objPtr, " 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", + Tcl_AppendPrintfToObj(objPtr, " Bytes with sharing %.6g\n", currentLiteralBytes); Tcl_AppendPrintfToObj(objPtr, " table %lu + bkts %lu + entries %lu + objects %lu + strings %.6g\n", (unsigned long) sizeof(LiteralTable), @@ -10063,13 +8351,13 @@ EvalStatsCmd( (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", + Tcl_AppendPrintfToObj(objPtr, " 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", + Tcl_AppendPrintfToObj(objPtr, " String sharing savings %.6g = unshared %.6g - shared %.6g\n", (strBytesIfUnshared - statsPtr->currentLitStringBytes), strBytesIfUnshared, statsPtr->currentLitStringBytes); - Tcl_AppendPrintfToObj(objPtr, " Literal mgmt overhead\t\t%" TCL_Z_MODIFIER "u (%0.1f%% of bytes with sharing)\n", + Tcl_AppendPrintfToObj(objPtr, " 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", @@ -10117,10 +8405,9 @@ EvalStatsCmd( */ Tcl_AppendPrintfToObj(objPtr, "\nLiteral string sizes:\n"); - Tcl_AppendPrintfToObj(objPtr, "\t Up to length\t\tPercentage\n"); + Tcl_AppendPrintfToObj(objPtr, " Up to length Percentage\n"); maxSizeDecade = 0; - i = 32; - while (i-- > 0) { + for (i = 31; i >= 0; i--) { if (statsPtr->literalCount[i] > 0) { maxSizeDecade = i; break; @@ -10130,21 +8417,21 @@ EvalStatsCmd( for (i = 0; i <= maxSizeDecade; i++) { decadeHigh = (1 << (i+1)) - 1; sum += statsPtr->literalCount[i]; - Tcl_AppendPrintfToObj(objPtr, "\t%10" TCL_SIZE_MODIFIER "d\t\t%8.0f%%\n", + Tcl_AppendPrintfToObj(objPtr, " %10d %8.0f%%\n", decadeHigh, Percent(sum, statsPtr->numLiteralsCreated)); } litTableStats = TclLiteralStats(globalTablePtr); Tcl_AppendPrintfToObj(objPtr, "\nCurrent literal table statistics:\n%s\n", litTableStats); - ckfree(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"); + Tcl_AppendPrintfToObj(objPtr, " Up to size Percentage\n"); minSizeDecade = maxSizeDecade = 0; for (i = 0; i < 31; i++) { if (statsPtr->srcCount[i] > 0) { @@ -10152,7 +8439,7 @@ EvalStatsCmd( break; } } - for (i = 31; i != (size_t)-1; i--) { + for (i = 31; i >= 0; i--) { if (statsPtr->srcCount[i] > 0) { maxSizeDecade = i; break; @@ -10162,12 +8449,12 @@ EvalStatsCmd( for (i = minSizeDecade; i <= maxSizeDecade; i++) { decadeHigh = (1 << (i+1)) - 1; sum += statsPtr->srcCount[i]; - Tcl_AppendPrintfToObj(objPtr, "\t%10" TCL_SIZE_MODIFIER "d\t\t%8.0f%%\n", + Tcl_AppendPrintfToObj(objPtr, " %10d %8.0f%%\n", decadeHigh, Percent(sum, statsPtr->numCompilations)); } Tcl_AppendPrintfToObj(objPtr, "\nByteCode sizes:\n"); - Tcl_AppendPrintfToObj(objPtr, "\t Up to size\t\tPercentage\n"); + Tcl_AppendPrintfToObj(objPtr, " Up to size Percentage\n"); minSizeDecade = maxSizeDecade = 0; for (i = 0; i < 31; i++) { if (statsPtr->byteCodeCount[i] > 0) { @@ -10175,7 +8462,7 @@ EvalStatsCmd( break; } } - for (i = 31; i != (size_t)-1; i--) { + for (i = 31; i >= 0; i--) { if (statsPtr->byteCodeCount[i] > 0) { maxSizeDecade = i; break; @@ -10185,12 +8472,12 @@ EvalStatsCmd( for (i = minSizeDecade; i <= maxSizeDecade; i++) { decadeHigh = (1 << (i+1)) - 1; sum += statsPtr->byteCodeCount[i]; - Tcl_AppendPrintfToObj(objPtr, "\t%10" TCL_SIZE_MODIFIER "d\t\t%8.0f%%\n", + Tcl_AppendPrintfToObj(objPtr, " %10d %8.0f%%\n", decadeHigh, Percent(sum, statsPtr->numCompilations)); } Tcl_AppendPrintfToObj(objPtr, "\nByteCode longevity (excludes Current ByteCodes):\n"); - Tcl_AppendPrintfToObj(objPtr, "\t Up to ms\t\tPercentage\n"); + Tcl_AppendPrintfToObj(objPtr, " Up to ms Percentage\n"); minSizeDecade = maxSizeDecade = 0; for (i = 0; i < 31; i++) { if (statsPtr->lifetimeCount[i] > 0) { @@ -10198,7 +8485,7 @@ EvalStatsCmd( break; } } - for (i = 31; i != (size_t)-1; i--) { + for (i = 31; i >= 0; i--) { if (statsPtr->lifetimeCount[i] > 0) { maxSizeDecade = i; break; @@ -10208,7 +8495,7 @@ EvalStatsCmd( 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", + Tcl_AppendPrintfToObj(objPtr, " %12.3f %8.0f%%\n", decadeHigh/1000.0, Percent(sum, statsPtr->numByteCodesFreed)); } @@ -10218,7 +8505,7 @@ EvalStatsCmd( Tcl_AppendPrintfToObj(objPtr, "\nInstruction counts:\n"); for (i = 0; i <= LAST_INST_OPCODE; i++) { - Tcl_AppendPrintfToObj(objPtr, "%20s %8" TCL_Z_MODIFIER "u ", + Tcl_AppendPrintfToObj(objPtr, "%20s %8ld ", tclInstructionTable[i].name, statsPtr->instructionCount[i]); if (statsPtr->instructionCount[i]) { Tcl_AppendPrintfToObj(objPtr, "%6.1f%%\n", @@ -10230,7 +8517,7 @@ EvalStatsCmd( #ifdef TCL_MEM_DEBUG Tcl_AppendPrintfToObj(objPtr, "\nHeap Statistics:\n"); - TclDumpMemoryInfo(objPtr, 1); + TclDumpMemoryInfo((ClientData) objPtr, 1); #endif Tcl_AppendPrintfToObj(objPtr, "\n----------------------------------------------------------------\n"); @@ -10238,7 +8525,7 @@ EvalStatsCmd( Tcl_SetObjResult(interp, objPtr); } else { Tcl_Channel outChan; - char *str = TclGetStringFromObj(objv[1], &length); + char *str = Tcl_GetStringFromObj(objv[1], &length); if (length) { if (strcmp(str, "stdout") == 0) { |