diff options
Diffstat (limited to 'generic/tclExecute.c')
| -rw-r--r-- | generic/tclExecute.c | 11549 |
1 files changed, 7330 insertions, 4219 deletions
diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 6fb49ec..4ecca5b 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -5,22 +5,25 @@ * * 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 by Donal K. Fellows. + * Copyright (c) 2001 by Kevin B. Kenny. All rights reserved. + * Copyright (c) 2002-2010 by Miguel Sofer. + * Copyright (c) 2005-2007 by Donal K. Fellows. + * Copyright (c) 2007 Daniel A. Steffen <das@users.sourceforge.net> + * Copyright (c) 2006-2008 by Joe Mistachkin. All rights reserved. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: tclExecute.c,v 1.225 2005/12/27 20:14:08 kennykb Exp $ */ #include "tclInt.h" #include "tclCompile.h" +#include "tclOOInt.h" #include "tommath.h" - #include <math.h> -#include <float.h> + +#if NRE_ENABLE_ASSERTS +#include <assert.h> +#endif /* * Hack to determine whether we may expect IEEE floating point. The hack is @@ -29,27 +32,11 @@ * point units that we might care about? */ -#if ( FLT_RADIX == 2 ) && ( DBL_MANT_DIG == 53 ) && ( DBL_MAX_EXP == 1024 ) +#if (FLT_RADIX == 2) && (DBL_MANT_DIG == 53) && (DBL_MAX_EXP == 1024) #define IEEE_FLOATING_POINT #endif /* - * The stuff below is a bit of a hack so that this file can be used in - * environments that include no UNIX. - * TODO: Does this serve any purpose anymore? - */ - -#ifdef TCL_GENERIC_ONLY -# ifndef NO_FLOAT_H -# include <float.h> -# else /* NO_FLOAT_H */ -# ifndef NO_VALUES_H -# include <values.h> -# endif /* !NO_VALUES_H */ -# endif /* !NO_FLOAT_H */ -#endif /* !TCL_GENERIC_ONLY */ - -/* * 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. @@ -59,7 +46,6 @@ # define ASYNC_CHECK_COUNT_MASK 63 #endif /* !ASYNC_CHECK_COUNT_MASK */ - /* * Boolean flag indicating whether the Tcl bytecode interpreter has been * initialized. @@ -68,6 +54,8 @@ 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, @@ -88,10 +76,10 @@ 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-compatability reasons + * disjoint for backward-compatability reasons. */ -static CONST char *operatorStrings[] = { +static const char *const operatorStrings[] = { "||", "&&", "|", "^", "&", "==", "!=", "<", ">", "<=", ">=", "<<", ">>", "+", "-", "*", "/", "%", "+", "-", "~", "!", "BUILTIN FUNCTION", "FUNCTION", @@ -104,7 +92,7 @@ static CONST char *operatorStrings[] = { */ #ifdef TCL_COMPILE_DEBUG -static char *resultStrings[] = { +static const char *const resultStrings[] = { "TCL_OK", "TCL_ERROR", "TCL_RETURN", "TCL_BREAK", "TCL_CONTINUE" }; #endif @@ -115,12 +103,140 @@ static char *resultStrings[] = { #ifdef TCL_COMPILE_STATS long tclObjsAlloced = 0; -long tclObjsFreed = 0; -#define TCL_MAX_SHARED_OBJ_STATS 5 +long tclObjsFreed = 0; long tclObjsShared[TCL_MAX_SHARED_OBJ_STATS] = { 0, 0, 0, 0, 0 }; #endif /* TCL_COMPILE_STATS */ /* + * Support pre-8.5 bytecodes unless specifically requested otherwise. + */ + +#ifndef TCL_SUPPORT_84_BYTECODE +#define TCL_SUPPORT_84_BYTECODE 1 +#endif + +#if TCL_SUPPORT_84_BYTECODE +/* + * We need to know the tclBuiltinFuncTable to support translation of pre-8.5 + * math functions to the namespace-based ::tcl::mathfunc::op in 8.5+. + */ + +typedef struct { + const char *name; /* Name of function. */ + int numArgs; /* Number of arguments for function. */ +} BuiltinFunc; + +/* + * Table describing the built-in math functions. Entries in this table are + * indexed by the values of the INST_CALL_BUILTIN_FUNC instruction's + * operand byte. + */ + +static BuiltinFunc const tclBuiltinFuncTable[] = { + {"acos", 1}, + {"asin", 1}, + {"atan", 1}, + {"atan2", 2}, + {"ceil", 1}, + {"cos", 1}, + {"cosh", 1}, + {"exp", 1}, + {"floor", 1}, + {"fmod", 2}, + {"hypot", 2}, + {"log", 1}, + {"log10", 1}, + {"pow", 2}, + {"sin", 1}, + {"sinh", 1}, + {"sqrt", 1}, + {"tan", 1}, + {"tanh", 1}, + {"abs", 1}, + {"double", 1}, + {"int", 1}, + {"rand", 0}, + {"round", 1}, + {"srand", 1}, + {"wide", 1}, + {NULL, 0}, +}; + +#define LAST_BUILTIN_FUNC 25 +#endif + +/* + * NR_TEBC + * Helpers for NR - non-recursive calls to TEBC + * Minimal data required to fully reconstruct the execution state. + */ + +typedef struct TEBCdata { + ByteCode *codePtr; /* Constant until the BC returns */ + /* -----------------------------------------*/ + ptrdiff_t *catchTop; /* These fields are used on return TO this */ + Tcl_Obj *auxObjList; /* this level: they record the state when a */ + CmdFrame cmdFrame; /* new codePtr was received for NR */ + /* execution. */ + void *stack[1]; /* Start of the actual combined catch and obj + * stacks; the struct will be expanded as + * necessary */ +} TEBCdata; + +#define TEBC_YIELD() \ + do { \ + esPtr->tosPtr = tosPtr; \ + 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.ptrAndLongRep.ptr = auxObjList; \ + auxObjList = objPtr; \ + } while (0) + +#define POP_TAUX_OBJ() \ + do { \ + tmpPtr = auxObjList; \ + auxObjList = tmpPtr->internalRep.ptrAndLongRep.ptr; \ + Tcl_DecrRefCount(tmpPtr); \ + } while (0) + +/* + * These variable-access macros have to coincide with those in tclVar.c + */ + +#define VarHashGetValue(hPtr) \ + ((Var *) ((char *)hPtr - TclOffset(VarInHash, entry))) + +static inline Var * +VarHashCreateVar( + TclVarHashTable *tablePtr, + Tcl_Obj *key, + int *newPtr) +{ + Tcl_HashEntry *hPtr = Tcl_CreateHashEntry(&tablePtr->table, + key, newPtr); + + if (!hPtr) { + return NULL; + } + return VarHashGetValue(hPtr); +} + +#define VarHashFindVar(tablePtr, key) \ + VarHashCreateVar((tablePtr), (key), NULL) + +/* * The new macro for ending an instruction; note that a reasonable C-optimiser * will resolve all branches at compile time. (result) is always a constant; * the macro NEXT_INST_F handles constant (nCleanup), NEXT_INST_V is resolved @@ -132,66 +248,150 @@ long tclObjsShared[TCL_MAX_SHARED_OBJ_STATS] = { 0, 0, 0, 0, 0 }; * 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. */ -#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("ERROR: bad usage of macro NEXT_INST_F");\ - }\ - } else {\ - pc += (pcAdjustment);\ - switch (nCleanup) {\ - case 1: goto cleanup1;\ - case 2: goto cleanup2;\ - default: Tcl_Panic("ERROR: bad usage of macro NEXT_INST_F");\ - }\ - } - -#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;\ - } +/* 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) +#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); \ + case INST_JUMP_TRUE1: \ + NEXT_INST_F(((condition)? TclGetInt1AtPtr(pc+1) : 2), (cleanup), 0); \ + case INST_JUMP_FALSE4: \ + NEXT_INST_F(((condition)? 5 : TclGetInt4AtPtr(pc+1)), (cleanup), 0); \ + case INST_JUMP_TRUE4: \ + NEXT_INST_F(((condition)? TclGetInt4AtPtr(pc+1) : 5), (cleanup), 0); \ + default: \ + if ((condition) < 0) { \ + TclNewIntObj(objResultPtr, -1); \ + } else { \ + objResultPtr = TCONST((condition) > 0); \ + } \ + NEXT_INST_F(0, (cleanup), 1); \ + } \ + } 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); \ + case INST_JUMP_TRUE1: \ + NEXT_INST_V(((condition)? TclGetInt1AtPtr(pc+1) : 2), (cleanup), 0); \ + case INST_JUMP_FALSE4: \ + NEXT_INST_V(((condition)? 5 : TclGetInt4AtPtr(pc+1)), (cleanup), 0); \ + case INST_JUMP_TRUE4: \ + NEXT_INST_V(((condition)? TclGetInt4AtPtr(pc+1) : 5), (cleanup), 0); \ + default: \ + if ((condition) < 0) { \ + TclNewIntObj(objResultPtr, -1); \ + } else { \ + objResultPtr = TCONST((condition) > 0); \ + } \ + NEXT_INST_V(0, (cleanup), 1); \ + } \ + } 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 /* * Macros used to cache often-referenced Tcl evaluation stack information * in local variables. Note that a DECACHE_STACK_INFO()-CACHE_STACK_INFO() - * pair must surround any call inside TclExecuteByteCode (and a few other + * pair must surround any call inside TclNRExecuteByteCode (and a few other * procedures that use this scheme) that could result in a recursive call - * to TclExecuteByteCode. + * to TclNRExecuteByteCode. */ #define CACHE_STACK_INFO() \ - tosPtr = eePtr->tosPtr - -#define DECACHE_STACK_INFO() \ - eePtr->tosPtr = tosPtr;\ checkInterp = 1 +#define DECACHE_STACK_INFO() \ + esPtr->tosPtr = tosPtr /* * Macros used to access items on the Tcl evaluation stack. PUSH_OBJECT @@ -211,90 +411,90 @@ long tclObjsShared[TCL_MAX_SHARED_OBJ_STATS] = { 0, 0, 0, 0, 0 }; #define PUSH_OBJECT(objPtr) \ Tcl_IncrRefCount(*(++tosPtr) = (objPtr)) -#define POP_OBJECT() \ - *(tosPtr--) +#define POP_OBJECT() *(tosPtr--) + +#define OBJ_AT_TOS *tosPtr + +#define OBJ_UNDER_TOS *(tosPtr-1) + +#define OBJ_AT_DEPTH(n) *(tosPtr-(n)) + +#define CURR_DEPTH ((ptrdiff_t) (tosPtr - initTosPtr)) + +#define STACK_BASE(esPtr) ((esPtr)->stackWords - 1) /* * Macros used to trace instruction execution. The macros TRACE, - * TRACE_WITH_OBJ, and O2S are only used inside TclExecuteByteCode. O2S is + * TRACE_WITH_OBJ, and O2S are only used inside TclNRExecuteByteCode. O2S is * only used in TRACE* calls to get a string from an object. */ #ifdef TCL_COMPILE_DEBUG # define TRACE(a) \ - if (traceInstructions) { \ - fprintf(stdout, "%2d: %2d (%u) %s ", iPtr->numLevels, \ - (tosPtr - eePtr->stackPtr), \ - (unsigned int)(pc - codePtr->codeStart), \ - GetOpcodeName(pc)); \ - printf a; \ + while (traceInstructions) { \ + fprintf(stdout, "%2d: %2d (%u) %s ", iPtr->numLevels, \ + (int) CURR_DEPTH, \ + (unsigned) (pc - codePtr->codeStart), \ + GetOpcodeName(pc)); \ + printf a; \ + break; \ } # define TRACE_APPEND(a) \ - if (traceInstructions) { \ - printf a; \ + while (traceInstructions) { \ + printf a; \ + break; \ } +# define TRACE_ERROR(interp) \ + TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); # define TRACE_WITH_OBJ(a, objPtr) \ - if (traceInstructions) { \ - fprintf(stdout, "%2d: %2d (%u) %s ", iPtr->numLevels, \ - (tosPtr - eePtr->stackPtr), \ - (unsigned int)(pc - codePtr->codeStart), \ - GetOpcodeName(pc)); \ - printf a; \ - TclPrintObject(stdout, objPtr, 30); \ - fprintf(stdout, "\n"); \ + while (traceInstructions) { \ + fprintf(stdout, "%2d: %2d (%u) %s ", iPtr->numLevels, \ + (int) CURR_DEPTH, \ + (unsigned) (pc - codePtr->codeStart), \ + GetOpcodeName(pc)); \ + printf a; \ + TclPrintObject(stdout, objPtr, 30); \ + fprintf(stdout, "\n"); \ + break; \ } # 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 */ -#if 0 /* - * Macro to read a string containing either a wide or an int and decide which - * it is while decoding it at the same time. This enforces the policy that - * integer constants between LONG_MIN and LONG_MAX (inclusive) are represented - * by normal longs, and integer constants outside that range are represented - * by wide ints. - * - * GET_WIDE_OR_INT is the same as REQUIRE_WIDE_OR_INT except it never - * generates an error message. + * DTrace instruction probe macros. */ -#define REQUIRE_WIDE_OR_INT(resultVar, objPtr, longVar, wideVar) \ - (resultVar) = Tcl_GetWideIntFromObj(interp, (objPtr), &(wideVar)); \ - if ((resultVar) == TCL_OK && (wideVar) >= Tcl_LongAsWide(LONG_MIN) \ - && (wideVar) <= Tcl_LongAsWide(LONG_MAX)) { \ - (objPtr)->typePtr = &tclIntType; \ - (objPtr)->internalRep.longValue = (longVar) \ - = Tcl_WideAsLong(wideVar); \ - } -#define GET_WIDE_OR_INT(resultVar, objPtr, longVar, wideVar) \ - (resultVar) = Tcl_GetWideIntFromObj((Tcl_Interp *) NULL, (objPtr), \ - &(wideVar)); \ - if ((resultVar) == TCL_OK && (wideVar) >= Tcl_LongAsWide(LONG_MIN) \ - && (wideVar) <= Tcl_LongAsWide(LONG_MAX)) { \ - (objPtr)->typePtr = &tclIntType; \ - (objPtr)->internalRep.longValue = (longVar) \ - = Tcl_WideAsLong(wideVar); \ - } -#endif - -/* - * Combined with REQUIRE_WIDE_OR_INT, this gets a long value from an obj. - */ - -#if 0 -#define W0 Tcl_LongAsWide(0) -/* - * For tracing that uses wide values. - */ -#define LLD "%" TCL_LL_MODIFIER "d" -#endif - +#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) { \ + TCL_DTRACE_INST_DONE(curInstName, (int) CURR_DEPTH, tosPtr);\ + } \ + } while (0) + /* * Macro used in this file to save a function call for common uses of * TclGetNumberFromObj(). The ANSI C "prototype" is: @@ -303,9 +503,8 @@ long tclObjsShared[TCL_MAX_SHARED_OBJ_STATS] = { 0, 0, 0, 0, 0 }; * ClientData *ptrPtr, int *tPtr); */ -#ifdef NO_WIDE_TYPE - -#define GetNumberFromObj(interp, objPtr, ptrPtr, tPtr) \ +#ifdef TCL_WIDE_INT_IS_LONG +#define GetNumberFromObj(interp, objPtr, ptrPtr, tPtr) \ (((objPtr)->typePtr == &tclIntType) \ ? (*(tPtr) = TCL_NUMBER_LONG, \ *(ptrPtr) = (ClientData) \ @@ -318,12 +517,10 @@ long tclObjsShared[TCL_MAX_SHARED_OBJ_STATS] = { 0, 0, 0, 0, 0 }; (&((objPtr)->internalRep.doubleValue)), TCL_OK) : \ ((((objPtr)->typePtr == NULL) && ((objPtr)->bytes == NULL)) || \ (((objPtr)->bytes != NULL) && ((objPtr)->length == 0))) \ - ? TCL_ERROR : \ + ? (*(tPtr) = TCL_NUMBER_LONG),TCL_ERROR : \ TclGetNumberFromObj((interp), (objPtr), (ptrPtr), (tPtr))) - -#else - -#define GetNumberFromObj(interp, objPtr, ptrPtr, tPtr) \ +#else /* !TCL_WIDE_INT_IS_LONG */ +#define GetNumberFromObj(interp, objPtr, ptrPtr, tPtr) \ (((objPtr)->typePtr == &tclIntType) \ ? (*(tPtr) = TCL_NUMBER_LONG, \ *(ptrPtr) = (ClientData) \ @@ -340,40 +537,39 @@ long tclObjsShared[TCL_MAX_SHARED_OBJ_STATS] = { 0, 0, 0, 0, 0 }; (&((objPtr)->internalRep.doubleValue)), TCL_OK) : \ ((((objPtr)->typePtr == NULL) && ((objPtr)->bytes == NULL)) || \ (((objPtr)->bytes != NULL) && ((objPtr)->length == 0))) \ - ? TCL_ERROR : \ + ? (*(tPtr) = TCL_NUMBER_LONG),TCL_ERROR : \ TclGetNumberFromObj((interp), (objPtr), (ptrPtr), (tPtr))) - -#endif +#endif /* TCL_WIDE_INT_IS_LONG */ /* * Macro used in this file to save a function call for common uses of - * Tcl_GetBooleanFromObj(). The ANSI C "prototype" is: + * Tcl_GetBooleanFromObj(). The ANSI C "prototype" is: * * MODULE_SCOPE int TclGetBooleanFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, * int *boolPtr); */ -#define TclGetBooleanFromObj(interp, objPtr, boolPtr) \ +#define TclGetBooleanFromObj(interp, objPtr, boolPtr) \ ((((objPtr)->typePtr == &tclIntType) \ - || ((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: + * 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) \ +#ifdef TCL_WIDE_INT_IS_LONG +#define TclGetWideIntFromObj(interp, objPtr, wideIntPtr) \ (((objPtr)->typePtr == &tclIntType) \ ? (*(wideIntPtr) = (Tcl_WideInt) \ ((objPtr)->internalRep.longValue), TCL_OK) : \ Tcl_GetWideIntFromObj((interp), (objPtr), (wideIntPtr))) -#else +#else /* !TCL_WIDE_INT_IS_LONG */ #define TclGetWideIntFromObj(interp, objPtr, wideIntPtr) \ (((objPtr)->typePtr == &tclWideIntType) \ ? (*(wideIntPtr) = (objPtr)->internalRep.wideValue, TCL_OK) : \ @@ -381,47 +577,295 @@ long tclObjsShared[TCL_MAX_SHARED_OBJ_STATS] = { 0, 0, 0, 0, 0 }; ? (*(wideIntPtr) = (Tcl_WideInt) \ ((objPtr)->internalRep.longValue), TCL_OK) : \ Tcl_GetWideIntFromObj((interp), (objPtr), (wideIntPtr))) +#endif /* TCL_WIDE_INT_IS_LONG */ + +/* + * Macro used to make the check for type overflow more mnemonic. This works by + * comparing sign bits; the rest of the word is irrelevant. The ANSI C + * "prototype" (where inttype_t is any integer type) is: + * + * MODULE_SCOPE int Overflowing(inttype_t a, inttype_t b, inttype_t sum); + * + * Check first the condition most likely to fail in usual code (at least for + * usage in [incr]: do the first summand and the sum have != signs? + */ + +#define Overflowing(a,b,sum) ((((a)^(sum)) < 0) && (((a)^(b)) >= 0)) + +/* + * Macro for checking whether the type is NaN, used when we're thinking about + * throwing an error for supplying a non-number number. + */ + +#ifndef ACCEPT_NAN +#define IsErroringNaNType(type) ((type) == TCL_NUMBER_NAN) +#else +#define IsErroringNaNType(type) 0 #endif + +/* + * Auxiliary tables used to compute powers of small integers. + */ -static Tcl_ObjType dictIteratorType = { - "dictIterator", - NULL, NULL, NULL, NULL +#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. + */ + +static const Tcl_WideInt MaxBase64[] = { + (Tcl_WideInt)46340*65536+62259, /* 3037000499 == isqrt(2**63-1) */ + (Tcl_WideInt)2097151, (Tcl_WideInt)55108, (Tcl_WideInt)6208, + (Tcl_WideInt)1448, (Tcl_WideInt)511, (Tcl_WideInt)234, (Tcl_WideInt)127, + (Tcl_WideInt)78, (Tcl_WideInt)52, (Tcl_WideInt)38, (Tcl_WideInt)28, + (Tcl_WideInt)22, (Tcl_WideInt)18, (Tcl_WideInt)15 +}; +static const size_t MaxBase64Size = sizeof(MaxBase64)/sizeof(Tcl_WideInt); + +/* + * 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 Tcl_WideInt Exp64Value[] = { + (Tcl_WideInt)243*243*243*3*3, + (Tcl_WideInt)243*243*243*3*3*3, + (Tcl_WideInt)243*243*243*3*3*3*3, + (Tcl_WideInt)243*243*243*243, + (Tcl_WideInt)243*243*243*243*3, + (Tcl_WideInt)243*243*243*243*3*3, + (Tcl_WideInt)243*243*243*243*3*3*3, + (Tcl_WideInt)243*243*243*243*3*3*3*3, + (Tcl_WideInt)243*243*243*243*243, + (Tcl_WideInt)243*243*243*243*243*3, + (Tcl_WideInt)243*243*243*243*243*3*3, + (Tcl_WideInt)243*243*243*243*243*3*3*3, + (Tcl_WideInt)243*243*243*243*243*3*3*3*3, + (Tcl_WideInt)243*243*243*243*243*243, + (Tcl_WideInt)243*243*243*243*243*243*3, + (Tcl_WideInt)243*243*243*243*243*243*3*3, + (Tcl_WideInt)243*243*243*243*243*243*3*3*3, + (Tcl_WideInt)243*243*243*243*243*243*3*3*3*3, + (Tcl_WideInt)243*243*243*243*243*243*243, + (Tcl_WideInt)243*243*243*243*243*243*243*3, + (Tcl_WideInt)243*243*243*243*243*243*243*3*3, + (Tcl_WideInt)243*243*243*243*243*243*243*3*3*3, + (Tcl_WideInt)243*243*243*243*243*243*243*3*3*3*3, + (Tcl_WideInt)1024*1024*1024*4*4, + (Tcl_WideInt)1024*1024*1024*4*4*4, + (Tcl_WideInt)1024*1024*1024*4*4*4*4, + (Tcl_WideInt)1024*1024*1024*1024, + (Tcl_WideInt)1024*1024*1024*1024*4, + (Tcl_WideInt)1024*1024*1024*1024*4*4, + (Tcl_WideInt)1024*1024*1024*1024*4*4*4, + (Tcl_WideInt)1024*1024*1024*1024*4*4*4*4, + (Tcl_WideInt)1024*1024*1024*1024*1024, + (Tcl_WideInt)1024*1024*1024*1024*1024*4, + (Tcl_WideInt)1024*1024*1024*1024*1024*4*4, + (Tcl_WideInt)1024*1024*1024*1024*1024*4*4*4, + (Tcl_WideInt)1024*1024*1024*1024*1024*4*4*4*4, + (Tcl_WideInt)1024*1024*1024*1024*1024*1024, + (Tcl_WideInt)1024*1024*1024*1024*1024*1024*4, + (Tcl_WideInt)3125*3125*3125*5*5, + (Tcl_WideInt)3125*3125*3125*5*5*5, + (Tcl_WideInt)3125*3125*3125*5*5*5*5, + (Tcl_WideInt)3125*3125*3125*3125, + (Tcl_WideInt)3125*3125*3125*3125*5, + (Tcl_WideInt)3125*3125*3125*3125*5*5, + (Tcl_WideInt)3125*3125*3125*3125*5*5*5, + (Tcl_WideInt)3125*3125*3125*3125*5*5*5*5, + (Tcl_WideInt)3125*3125*3125*3125*3125, + (Tcl_WideInt)3125*3125*3125*3125*3125*5, + (Tcl_WideInt)3125*3125*3125*3125*3125*5*5, + (Tcl_WideInt)7776*7776*7776*6*6, + (Tcl_WideInt)7776*7776*7776*6*6*6, + (Tcl_WideInt)7776*7776*7776*6*6*6*6, + (Tcl_WideInt)7776*7776*7776*7776, + (Tcl_WideInt)7776*7776*7776*7776*6, + (Tcl_WideInt)7776*7776*7776*7776*6*6, + (Tcl_WideInt)7776*7776*7776*7776*6*6*6, + (Tcl_WideInt)7776*7776*7776*7776*6*6*6*6, + (Tcl_WideInt)16807*16807*16807*7*7, + (Tcl_WideInt)16807*16807*16807*7*7*7, + (Tcl_WideInt)16807*16807*16807*7*7*7*7, + (Tcl_WideInt)16807*16807*16807*16807, + (Tcl_WideInt)16807*16807*16807*16807*7, + (Tcl_WideInt)16807*16807*16807*16807*7*7, + (Tcl_WideInt)32768*32768*32768*8*8, + (Tcl_WideInt)32768*32768*32768*8*8*8, + (Tcl_WideInt)32768*32768*32768*8*8*8*8, + (Tcl_WideInt)32768*32768*32768*32768, + (Tcl_WideInt)59049*59049*59049*9*9, + (Tcl_WideInt)59049*59049*59049*9*9*9, + (Tcl_WideInt)59049*59049*59049*9*9*9*9, + (Tcl_WideInt)100000*100000*100000*10*10, + (Tcl_WideInt)100000*100000*100000*10*10*10, + (Tcl_WideInt)161051*161051*161051*11*11, + (Tcl_WideInt)161051*161051*161051*11*11*11, + (Tcl_WideInt)248832*248832*248832*12*12, + (Tcl_WideInt)371293*371293*371293*13*13 +}; +static const size_t Exp64ValueSize = sizeof(Exp64Value) / sizeof(Tcl_WideInt); +#endif /* (LONG_MAX > 0x7fffffff) || !defined(TCL_WIDE_INT_IS_LONG) */ + +/* + * Markers for ExecuteExtendedBinaryMathOp. + */ +#define DIVIDED_BY_ZERO ((Tcl_Obj *) -1) +#define EXPONENT_OF_ZERO ((Tcl_Obj *) -2) +#define GENERAL_ARITHMETIC_ERROR ((Tcl_Obj *) -3) + /* * Declarations for local procedures to this file: */ -static int TclExecuteByteCode(Tcl_Interp *interp, - ByteCode *codePtr); #ifdef TCL_COMPILE_STATS static int EvalStatsCmd(ClientData clientData, Tcl_Interp *interp, int objc, - Tcl_Obj *CONST objv[]); + Tcl_Obj *const objv[]); #endif /* TCL_COMPILE_STATS */ #ifdef TCL_COMPILE_DEBUG -static char * GetOpcodeName(unsigned char *pc); -#endif /* TCL_COMPILE_DEBUG */ -static ExceptionRange * GetExceptRangeForPc(unsigned char *pc, - int catchOnly, ByteCode* codePtr); -static char * GetSrcInfoForPc(unsigned char *pc, - ByteCode* codePtr, int *lengthPtr); -static void GrowEvaluationStack(ExecEnv *eePtr); -static void IllegalExprOperandType(Tcl_Interp *interp, - unsigned char *pc, Tcl_Obj *opndPtr); -static void InitByteCodeExecution(Tcl_Interp *interp); -#ifdef TCL_COMPILE_DEBUG +static const char * GetOpcodeName(const unsigned char *pc); static void PrintByteCodeInfo(ByteCode *codePtr); -static char * StringForResultCode(int result); +static const char * StringForResultCode(int result); static void ValidatePcAndStackTop(ByteCode *codePtr, - unsigned char *pc, int stackTop, - int stackLowerBound, int checkStack); + const unsigned char *pc, int stackTop, + int checkStack); #endif /* TCL_COMPILE_DEBUG */ -#if 0 -static Tcl_WideInt ExponWide(Tcl_WideInt w, Tcl_WideInt w2, - int *errExpon); -static long ExponLong(long i, long i2, int *errExpon); -#endif +static ByteCode * CompileExprObj(Tcl_Interp *interp, Tcl_Obj *objPtr); +static void DeleteExecStack(ExecStack *esPtr); +static void DupExprCodeInternalRep(Tcl_Obj *srcPtr, + Tcl_Obj *copyPtr); +MODULE_SCOPE int TclCompareTwoNumbers(Tcl_Obj *valuePtr, + Tcl_Obj *value2Ptr); +static Tcl_Obj * ExecuteExtendedBinaryMathOp(Tcl_Interp *interp, + int opcode, Tcl_Obj **constants, + Tcl_Obj *valuePtr, Tcl_Obj *value2Ptr); +static Tcl_Obj * ExecuteExtendedUnaryMathOp(int opcode, + Tcl_Obj *valuePtr); +static void FreeExprCodeInternalRep(Tcl_Obj *objPtr); +static ExceptionRange * GetExceptRangeForPc(const unsigned char *pc, + int catchOnly, ByteCode *codePtr); +static const char * GetSrcInfoForPc(const unsigned char *pc, + ByteCode *codePtr, int *lengthPtr, + const unsigned char **pcBeg, int *cmdIdxPtr); +static Tcl_Obj ** GrowEvaluationStack(ExecEnv *eePtr, int growth, + int move); +static void IllegalExprOperandType(Tcl_Interp *interp, + const unsigned char *pc, Tcl_Obj *opndPtr); +static void InitByteCodeExecution(Tcl_Interp *interp); +static inline int 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, int numWords); +static Tcl_Obj ** StackReallocWords(Tcl_Interp *interp, int numWords); +static Tcl_NRPostProc CopyCallback; +static Tcl_NRPostProc ExprObjCallback; +static Tcl_NRPostProc FinalizeOONext; +static Tcl_NRPostProc FinalizeOONextFilter; +static Tcl_NRPostProc TEBCresume; + +/* + * The structure below defines a bytecode Tcl object type to hold the + * compiled bytecode for Tcl expressions. + */ + +static const 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; + + /* + * First kill the search, and then release the reference to the dictionary + * that we were holding. + */ + + searchPtr = objPtr->internalRep.twoPtrValue.ptr1; + Tcl_DictObjDone(searchPtr); + ckfree(searchPtr); + + dictPtr = objPtr->internalRep.twoPtrValue.ptr2; + TclDecrRefCount(dictPtr); + + objPtr->typePtr = NULL; +} /* *---------------------------------------------------------------------- @@ -457,8 +901,7 @@ InitByteCodeExecution( } #endif #ifdef TCL_COMPILE_STATS - Tcl_CreateObjCommand(interp, "evalstats", EvalStatsCmd, - (ClientData) NULL, (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateObjCommand(interp, "evalstats", EvalStatsCmd, NULL, NULL); #endif /* TCL_COMPILE_STATS */ } @@ -470,7 +913,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 TclExecuteByteCode to execute ByteCode sequences + * recursively passed to TclNRExecuteByteCode to execute ByteCode sequences * for nested commands. * * Results: @@ -479,40 +922,37 @@ InitByteCodeExecution( * * Side effects: * The bytecode interpreter is also initialized here, as this procedure - * will be called before any call to TclExecuteByteCode. + * will be called before any call to TclNRExecuteByteCode. * *---------------------------------------------------------------------- */ -#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. */ + int size) /* The initial stack size, in number of words + * [sizeof(Tcl_Obj*)] */ { - ExecEnv *eePtr = (ExecEnv *) ckalloc(sizeof(ExecEnv)); - Tcl_Obj **stackPtr; - - stackPtr = (Tcl_Obj **) - ckalloc((size_t) (TCL_STACK_INITIAL_SIZE * sizeof(Tcl_Obj *))); - - /* - * Use the bottom pointer to keep a reference count; the execution - * environment holds a reference. - */ - - stackPtr++; - eePtr->stackPtr = stackPtr; - stackPtr[-1] = (Tcl_Obj *) ((char *) 1); - - eePtr->tosPtr = stackPtr - 1; - eePtr->endPtr = stackPtr + (TCL_STACK_INITIAL_SIZE - 2); + ExecEnv *eePtr = ckalloc(sizeof(ExecEnv)); + ExecStack *esPtr = ckalloc(sizeof(ExecStack) + + (size_t) (size-1) * sizeof(Tcl_Obj *)); + eePtr->execStackPtr = esPtr; TclNewBooleanObj(eePtr->constants[0], 0); Tcl_IncrRefCount(eePtr->constants[0]); TclNewBooleanObj(eePtr->constants[1], 1); Tcl_IncrRefCount(eePtr->constants[1]); + eePtr->interp = interp; + eePtr->callbackPtr = NULL; + eePtr->corPtr = NULL; + eePtr->rewind = 0; + + esPtr->prevPtr = NULL; + esPtr->nextPtr = NULL; + esPtr->markerPtr = NULL; + esPtr->endPtr = &esPtr->stackWords[size-1]; + esPtr->tosPtr = STACK_BASE(esPtr); Tcl_MutexLock(&execMutex); if (!execInitialized) { @@ -524,7 +964,6 @@ TclCreateExecEnv( return eePtr; } -#undef TCL_STACK_INITIAL_SIZE /* *---------------------------------------------------------------------- @@ -543,18 +982,53 @@ TclCreateExecEnv( *---------------------------------------------------------------------- */ +static void +DeleteExecStack( + ExecStack *esPtr) +{ + if (esPtr->markerPtr && !cachedInExit) { + Tcl_Panic("freeing an execStack which is still in use"); + } + + if (esPtr->prevPtr) { + esPtr->prevPtr->nextPtr = esPtr->nextPtr; + } + if (esPtr->nextPtr) { + esPtr->nextPtr->prevPtr = esPtr->prevPtr; + } + ckfree(esPtr); +} + void TclDeleteExecEnv( ExecEnv *eePtr) /* Execution environment to free. */ { - if (eePtr->stackPtr[-1] == (Tcl_Obj *) ((char *) 1)) { - ckfree((char *) (eePtr->stackPtr-1)); - } else { - Tcl_Panic("ERROR: freeing an execEnv whose stack is still in use.\n"); + ExecStack *esPtr = eePtr->execStackPtr, *tmpPtr; + + cachedInExit = TclInExit(); + + /* + * Delete all stacks in this exec env. + */ + + while (esPtr->nextPtr) { + esPtr = esPtr->nextPtr; } + while (esPtr) { + tmpPtr = esPtr; + esPtr = tmpPtr->prevPtr; + DeleteExecStack(tmpPtr); + } + TclDecrRefCount(eePtr->constants[0]); TclDecrRefCount(eePtr->constants[1]); - ckfree((char *) eePtr); + 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); } /* @@ -585,78 +1059,199 @@ TclFinalizeExecution(void) } /* + * Auxiliary code to insure that GrowEvaluationStack always returns correctly + * aligned memory. + * + * WALLOCALIGN represents the alignment reqs in words, just as TCL_ALLOCALIGN + * represents the reqs in bytes. This assumes that TCL_ALLOCALIGN is a + * multiple of the wordsize 'sizeof(Tcl_Obj *)'. + */ + +#define WALLOCALIGN \ + (TCL_ALLOCALIGN/sizeof(Tcl_Obj *)) + +/* + * wordSkip computes how many words have to be skipped until the next aligned + * word. Note that we are only interested in the low order bits of ptr, so + * that any possible information loss in PTR2INT is of no consequence. + */ + +static inline int +wordSkip( + void *ptr) +{ + int mask = TCL_ALLOCALIGN-1; + int base = PTR2INT(ptr) & mask; + return (TCL_ALLOCALIGN - base)/sizeof(Tcl_Obj *); +} + +/* + * Given a marker, compute where the following aligned memory starts. + */ + +#define MEMSTART(markerPtr) \ + ((markerPtr) + wordSkip(markerPtr)) + +/* *---------------------------------------------------------------------- * * GrowEvaluationStack -- * - * This procedure grows a Tcl evaluation stack stored in an ExecEnv. + * This procedure grows a Tcl evaluation stack stored in an ExecEnv, + * copying over the words since the last mark if so requested. A mark is + * set at the beginning of the new area when no copying is requested. * * Results: - * None. + * Returns a pointer to the first usable word in the (possibly) grown + * stack. * * Side effects: - * The size of the evaluation stack is doubled. + * The size of the evaluation stack may be grown, a marker is set * *---------------------------------------------------------------------- */ -static void +static Tcl_Obj ** GrowEvaluationStack( - register ExecEnv *eePtr) /* Points to the ExecEnv with an evaluation + ExecEnv *eePtr, /* Points to the ExecEnv with an evaluation * stack to enlarge. */ + int growth, /* How much larger than the current used + * size. */ + int move) /* 1 if move words since last marker. */ { + ExecStack *esPtr = eePtr->execStackPtr, *oldPtr = NULL; + int newBytes, newElems, currElems; + int needed = growth - (esPtr->endPtr - esPtr->tosPtr); + Tcl_Obj **markerPtr = esPtr->markerPtr, **memStart; + int moveWords = 0; + + if (move) { + if (!markerPtr) { + Tcl_Panic("STACK: Reallocating with no previous alloc"); + } + if (needed <= 0) { + return MEMSTART(markerPtr); + } + } else { +#ifndef PURIFY + Tcl_Obj **tmpMarkerPtr = esPtr->tosPtr + 1; + int offset = wordSkip(tmpMarkerPtr); + + if (needed + offset < 0) { + /* + * Put a marker pointing to the previous marker in this stack, and + * store it in esPtr as the current marker. Return a pointer to + * the start of aligned memory. + */ + + esPtr->markerPtr = tmpMarkerPtr; + memStart = tmpMarkerPtr + offset; + esPtr->tosPtr = memStart - 1; + *esPtr->markerPtr = (Tcl_Obj *) markerPtr; + return memStart; + } +#endif + } + /* - * The current Tcl stack elements are stored from *(eePtr->stackPtr) to - * *(eePtr->endPtr) (inclusive). + * Reset move to hold the number of words to be moved to new stack (if + * any) and growth to hold the complete stack requirements: add one for + * the marker, (WALLOCALIGN-1) for the maximal possible offset. */ - int currElems = (eePtr->endPtr - eePtr->stackPtr + 1); - int newElems = 2*currElems; - int currBytes = currElems * sizeof(Tcl_Obj *); - int newBytes = 2*currBytes; - Tcl_Obj **newStackPtr = (Tcl_Obj **) ckalloc((unsigned) newBytes); - Tcl_Obj **oldStackPtr = eePtr->stackPtr; + if (move) { + moveWords = esPtr->tosPtr - MEMSTART(markerPtr) + 1; + } + needed = growth + moveWords + WALLOCALIGN; + /* - * We keep the stack reference count as a (char *), as that works nicely - * as a portable pointer-sized counter. + * Check if there is enough room in the next stack (if there is one, it + * should be both empty and the last one!) */ - char *refCount = (char *) oldStackPtr[-1]; + if (esPtr->nextPtr) { + oldPtr = esPtr; + esPtr = oldPtr->nextPtr; + currElems = esPtr->endPtr - STACK_BASE(esPtr); + if (esPtr->markerPtr || (esPtr->tosPtr != STACK_BASE(esPtr))) { + Tcl_Panic("STACK: Stack after current is in use"); + } + if (esPtr->nextPtr) { + Tcl_Panic("STACK: Stack after current is not last"); + } + if (needed <= currElems) { + goto newStackReady; + } + DeleteExecStack(esPtr); + esPtr = oldPtr; + } else { + currElems = esPtr->endPtr - STACK_BASE(esPtr); + } /* - * Copy the existing stack items to the new stack space, free the old - * storage if appropriate, and record the refCount of the new stack held - * by the environment. + * We need to allocate a new stack! It needs to store 'growth' words, + * including the elements to be copied over and the new marker. */ - newStackPtr++; - memcpy((VOID *) newStackPtr, (VOID *) oldStackPtr, - (size_t) currBytes); +#ifndef PURIFY + newElems = 2*currElems; + while (needed > newElems) { + newElems *= 2; + } +#else + newElems = needed; +#endif + + newBytes = sizeof(ExecStack) + (newElems-1) * sizeof(Tcl_Obj *); - if (refCount == (char *) 1) { - ckfree((VOID *) (oldStackPtr-1)); - } else { - /* - * Remove the reference corresponding to the environment pointer. - */ + oldPtr = esPtr; + esPtr = ckalloc(newBytes); + + oldPtr->nextPtr = esPtr; + esPtr->prevPtr = oldPtr; + esPtr->nextPtr = NULL; + esPtr->endPtr = &esPtr->stackWords[newElems-1]; + + newStackReady: + eePtr->execStackPtr = esPtr; - oldStackPtr[-1] = (Tcl_Obj *) (refCount-1); + /* + * Store a NULL marker at the beginning of the stack, to indicate that + * this is the first marker in this stack and that rewinding to here + * should actually be a return to the previous stack. + */ + + esPtr->stackWords[0] = NULL; + esPtr->markerPtr = &esPtr->stackWords[0]; + memStart = MEMSTART(esPtr->markerPtr); + esPtr->tosPtr = memStart - 1; + + if (move) { + memcpy(memStart, MEMSTART(markerPtr), moveWords*sizeof(Tcl_Obj *)); + esPtr->tosPtr += moveWords; + oldPtr->markerPtr = (Tcl_Obj **) *markerPtr; + oldPtr->tosPtr = markerPtr-1; + } + + /* + * Free the old stack if it is now unused. + */ + + if (!oldPtr->markerPtr) { + DeleteExecStack(oldPtr); } - eePtr->stackPtr = newStackPtr; - eePtr->endPtr = newStackPtr + (newElems - 2); /* index of last usable item */ - eePtr->tosPtr += (newStackPtr - oldStackPtr); - newStackPtr[-1] = (Tcl_Obj *) ((char *) 1); + return memStart; } /* *-------------------------------------------------------------- * - * TclStackAlloc -- + * TclStackAlloc, TclStackRealloc, TclStackFree -- * * Allocate memory from the execution stack; it has to be returned later - * with a call to TclStackFree + * with a call to TclStackFree. * * Results: * A pointer to the first byte allocated, or panics if the allocation did @@ -668,65 +1263,144 @@ GrowEvaluationStack( *-------------------------------------------------------------- */ -char * -TclStackAlloc( +static Tcl_Obj ** +StackAllocWords( Tcl_Interp *interp, - int numBytes) + int numWords) { + /* + * Note that GrowEvaluationStack sets a marker in the stack. This marker + * is read when rewinding, e.g., by TclStackFree. + */ + Interp *iPtr = (Interp *) interp; ExecEnv *eePtr = iPtr->execEnvPtr; - int numWords; - Tcl_Obj **tosPtr = eePtr->tosPtr; - char **stackRefCountPtr; + Tcl_Obj **resPtr = GrowEvaluationStack(eePtr, numWords, 0); - /* - * Add two words to store - * - a pointer to the used execution stack - * - the number of words reserved - * These will be used later by TclStackFree. - */ + eePtr->execStackPtr->tosPtr += numWords; + return resPtr; +} + +static Tcl_Obj ** +StackReallocWords( + Tcl_Interp *interp, + int numWords) +{ + Interp *iPtr = (Interp *) interp; + ExecEnv *eePtr = iPtr->execEnvPtr; + Tcl_Obj **resPtr = GrowEvaluationStack(eePtr, numWords, 1); + + eePtr->execStackPtr->tosPtr += numWords; + return resPtr; +} - numWords = (numBytes + 3*sizeof(void *) - 1)/sizeof(void *); +void +TclStackFree( + Tcl_Interp *interp, + void *freePtr) +{ + Interp *iPtr = (Interp *) interp; + ExecEnv *eePtr; + ExecStack *esPtr; + Tcl_Obj **markerPtr, *marker; - while ((tosPtr + numWords) > eePtr->endPtr) { - GrowEvaluationStack(eePtr); - tosPtr = eePtr->tosPtr; + if (iPtr == NULL || iPtr->execEnvPtr == NULL) { + ckfree((char *) freePtr); + return; } /* - * Increase the stack's reference count, to make sure it is not freed - * prematurely. + * Rewind the stack to the previous marker position. The current marker, + * as set in the last call to GrowEvaluationStack, contains a pointer to + * the previous marker. */ - stackRefCountPtr = (char **) (eePtr->stackPtr-1); - ++*stackRefCountPtr; + eePtr = iPtr->execEnvPtr; + esPtr = eePtr->execStackPtr; + markerPtr = esPtr->markerPtr; + marker = *markerPtr; + + if ((freePtr != NULL) && (MEMSTART(markerPtr) != (Tcl_Obj **)freePtr)) { + Tcl_Panic("TclStackFree: incorrect freePtr (%p != %p). Call out of sequence?", + freePtr, MEMSTART(markerPtr)); + } + + esPtr->tosPtr = markerPtr - 1; + esPtr->markerPtr = (Tcl_Obj **) marker; + if (marker) { + return; + } /* - * Reserve the space in the exec stack, and store the data for freeing. + * Return to previous active stack. Note that repeated expansions or + * reallocs could have generated several unused intervening stacks: free + * them too. */ - eePtr->tosPtr += numWords; - *(eePtr->tosPtr-1) = (Tcl_Obj *) stackRefCountPtr; - *(eePtr->tosPtr) = (Tcl_Obj *) numWords; + 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; + } +} - return (char *) (tosPtr+1); +void * +TclStackAlloc( + Tcl_Interp *interp, + int numBytes) +{ + Interp *iPtr = (Interp *) interp; + int numWords = (numBytes + (sizeof(Tcl_Obj *) - 1))/sizeof(Tcl_Obj *); + + if (iPtr == NULL || iPtr->execEnvPtr == NULL) { + return (void *) ckalloc(numBytes); + } + + return (void *) StackAllocWords(interp, numWords); } -void -TclStackFree( - Tcl_Interp *interp) +void * +TclStackRealloc( + Tcl_Interp *interp, + void *ptr, + int numBytes) { Interp *iPtr = (Interp *) interp; - ExecEnv *eePtr = iPtr->execEnvPtr; - char **stackRefCountPtr; + ExecEnv *eePtr; + ExecStack *esPtr; + Tcl_Obj **markerPtr; + int numWords; + + if (iPtr == NULL || iPtr->execEnvPtr == NULL) { + return (void *) ckrealloc((char *) ptr, numBytes); + } - stackRefCountPtr = (char **) *(eePtr->tosPtr-1); - eePtr->tosPtr -= (int) *(eePtr->tosPtr); + eePtr = iPtr->execEnvPtr; + esPtr = eePtr->execStackPtr; + markerPtr = esPtr->markerPtr; - --*stackRefCountPtr; - if (*stackRefCountPtr == (char *) 0) { - ckfree((VOID *) stackRefCountPtr); + if (MEMSTART(markerPtr) != (Tcl_Obj **)ptr) { + Tcl_Panic("TclStackRealloc: incorrect ptr. Call out of sequence?"); } + + numWords = (numBytes + (sizeof(Tcl_Obj *) - 1))/sizeof(Tcl_Obj *); + return (void *) StackReallocWords(interp, numWords); } /* @@ -761,116 +1435,150 @@ Tcl_ExprObj( 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( + ClientData data[], + Tcl_Interp *interp, + int result) +{ + Tcl_Obj **resultPtrPtr = data[0]; + Tcl_Obj *resultPtr = 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( + ClientData data[], + Tcl_Interp *interp, + int result) +{ + Tcl_InterpState state = data[0]; + Tcl_Obj *resultPtr = 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. + * The caller must manage its refCount and arrange for a call to + * TclCleanupByteCode() when the last reference disappears. + * + * Side effects: + * The Tcl_ObjType of objPtr is changed to the "bytecode" type, + * and the ByteCode is kept in the internal rep (along with context + * data for checking validity) for faster operations the next time + * CompileExprObj is called on the same value. + * + *---------------------------------------------------------------------- + */ + +static ByteCode * +CompileExprObj( + Tcl_Interp *interp, + Tcl_Obj *objPtr) +{ Interp *iPtr = (Interp *) interp; CompileEnv compEnv; /* Compilation environment structure allocated * in frame. */ - LiteralTable *localTablePtr = &(compEnv.localLitTable); register ByteCode *codePtr = NULL; - /* Tcl Internal type of bytecode. Initialized + /* Tcl Internal type of bytecode. Initialized * to avoid compiler warning. */ - AuxData *auxDataPtr; - LiteralEntry *entryPtr; - Tcl_Obj *saveObjPtr, *resultPtr; - char *string; - int length, i, result; /* - * First handle some common expressions specially. + * 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; - string = Tcl_GetStringFromObj(objPtr, &length); - if (length == 1) { - if (*string == '0') { - TclNewBooleanObj(resultPtr, 0); - Tcl_IncrRefCount(resultPtr); - *resultPtrPtr = resultPtr; - return TCL_OK; - } else if (*string == '1') { - TclNewBooleanObj(resultPtr, 1); - Tcl_IncrRefCount(resultPtr); - *resultPtrPtr = resultPtr; - return TCL_OK; - } - } else if ((length == 2) && (*string == '!')) { - if (*(string+1) == '0') { - TclNewBooleanObj(resultPtr, 1); - Tcl_IncrRefCount(resultPtr); - *resultPtrPtr = resultPtr; - return TCL_OK; - } else if (*(string+1) == '1') { - TclNewBooleanObj(resultPtr, 0); - Tcl_IncrRefCount(resultPtr); - *resultPtrPtr = resultPtr; - return TCL_OK; - } - } - - /* - * Get the ByteCode from the object. If it exists, make sure it hasn't - * been invalidated by, e.g., someone redefining a command with a compile - * procedure (this might make the compiled code wrong). If necessary, - * convert the object to be a ByteCode object and compile it. Also, if - * the code was compiled in/for a different interpreter, we recompile it. - * - * Precompiled expressions, however, are immutable and therefore they are - * not recompiled, even if the epoch has changed. - */ - - if (objPtr->typePtr == &tclByteCodeType) { - codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr; + codePtr = objPtr->internalRep.twoPtrValue.ptr1; if (((Interp *) *codePtr->interpHandle != iPtr) - || (codePtr->compileEpoch != iPtr->compileEpoch)) { - if (codePtr->flags & TCL_BYTECODE_PRECOMPILED) { - if ((Interp *) *codePtr->interpHandle != iPtr) { - Tcl_Panic("Tcl_ExprObj: compiled expression jumped interps"); - } - codePtr->compileEpoch = iPtr->compileEpoch; - } else { - objPtr->typePtr->freeIntRepProc(objPtr); - objPtr->typePtr = (Tcl_ObjType *) NULL; - } + || (codePtr->compileEpoch != iPtr->compileEpoch) + || (codePtr->nsPtr != namespacePtr) + || (codePtr->nsEpoch != namespacePtr->resolverEpoch) + || (codePtr->localCachePtr != iPtr->varFramePtr->localCachePtr)) { + FreeExprCodeInternalRep(objPtr); } } - if (objPtr->typePtr != &tclByteCodeType) { - TclInitCompileEnv(interp, &compEnv, string, length); - result = TclCompileExpr(interp, string, length, &compEnv); - + if (objPtr->typePtr != &exprCodeType) { /* - * Free the compilation environment's literal table bucket array if it - * was dynamically allocated. + * TIP #280: No invoker (yet) - Expression compilation. */ - if (localTablePtr->buckets != localTablePtr->staticBuckets) { - ckfree((char *) localTablePtr->buckets); - } - - if (result != TCL_OK) { - /* - * Compilation errors. Free storage allocated for compilation. - */ - -#ifdef TCL_COMPILE_DEBUG - TclVerifyLocalLiteralTable(&compEnv); -#endif /*TCL_COMPILE_DEBUG*/ - entryPtr = compEnv.literalArrayPtr; - for (i = 0; i < compEnv.literalArrayNext; i++) { - TclReleaseLiteral(interp, entryPtr->objPtr); - entryPtr++; - } -#ifdef TCL_COMPILE_DEBUG - TclVerifyGlobalLiteralTable(iPtr); -#endif /*TCL_COMPILE_DEBUG*/ + int length; + const char *string = TclGetStringFromObj(objPtr, &length); - auxDataPtr = compEnv.auxDataArrayPtr; - for (i = 0; i < compEnv.auxDataArrayNext; i++) { - if (auxDataPtr->type->freeProc != NULL) { - auxDataPtr->type->freeProc(auxDataPtr->clientData); - } - auxDataPtr++; - } - TclFreeCompileEnv(&compEnv); - return result; - } + TclInitCompileEnv(interp, &compEnv, string, length, NULL, 0); + TclCompileExpr(interp, string, length, &compEnv, 0); /* * Successful compilation. If the expression yielded no instructions, @@ -890,100 +1598,115 @@ Tcl_ExprObj( TclEmitOpcode(INST_DONE, &compEnv); TclInitByteCodeObj(objPtr, &compEnv); + objPtr->typePtr = &exprCodeType; TclFreeCompileEnv(&compEnv); - codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr; + codePtr = objPtr->internalRep.twoPtrValue.ptr1; + if (iPtr->varFramePtr->localCachePtr) { + codePtr->localCachePtr = iPtr->varFramePtr->localCachePtr; + codePtr->localCachePtr->refCount++; + } #ifdef TCL_COMPILE_DEBUG if (tclTraceCompile == 2) { TclPrintByteCodeObj(interp, objPtr); + fflush(stdout); } #endif /* TCL_COMPILE_DEBUG */ } + return codePtr; +} + +/* + *---------------------------------------------------------------------- + * + * DupExprCodeInternalRep -- + * + * Part of the Tcl object type implementation for Tcl expression + * bytecode. We do not copy the bytecode intrep. Instead, we return + * without setting copyPtr->typePtr, so the copy is a plain string copy + * of the expression value, and if it is to be used as a compiled + * expression, it will just need a recompile. + * + * This makes sense, because with Tcl's copy-on-write practices, the + * usual (only?) time Tcl_DuplicateObj() will be called is when the copy + * is about to be modified, which would invalidate any copied bytecode + * anyway. The only reason it might make sense to copy the bytecode is if + * we had some modifying routines that operated directly on the intrep, + * like we do for lists and dicts. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ - /* - * Execute the expression after first saving the interpreter's result. - */ - - saveObjPtr = Tcl_GetObjResult(interp); - Tcl_IncrRefCount(saveObjPtr); - Tcl_ResetResult(interp); +static void +DupExprCodeInternalRep( + Tcl_Obj *srcPtr, + Tcl_Obj *copyPtr) +{ + return; +} + +/* + *---------------------------------------------------------------------- + * + * 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. + * + * Results: + * None. + * + * Side effects: + * May free allocated memory. Leaves objPtr untyped. + * + *---------------------------------------------------------------------- + */ - /* - * Increment the code's ref count while it is being executed. If - * afterwards no references to it remain, free the code. - */ +static void +FreeExprCodeInternalRep( + Tcl_Obj *objPtr) +{ + ByteCode *codePtr = objPtr->internalRep.twoPtrValue.ptr1; - codePtr->refCount++; - result = TclExecuteByteCode(interp, codePtr); + objPtr->typePtr = NULL; codePtr->refCount--; if (codePtr->refCount <= 0) { TclCleanupByteCode(codePtr); - objPtr->typePtr = NULL; - objPtr->internalRep.otherValuePtr = NULL; - } - - /* - * 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; } /* *---------------------------------------------------------------------- * - * TclCompEvalObj -- + * TclCompileObj -- * - * This procedure evaluates the script contained in a Tcl_Obj by first - * compiling it and then passing it to TclExecuteByteCode. + * This procedure compiles the script contained in a Tcl_Obj. * * Results: - * The return value is one of the return codes defined in tcl.h (such as - * TCL_OK), and interp->objResultPtr refers to a Tcl object that either - * contains the result of executing the code or an error message. + * A pointer to the corresponding ByteCode, never NULL. * * Side effects: - * Almost certainly, depending on the ByteCode's instructions. + * The object is shimmered to bytecode type. * *---------------------------------------------------------------------- */ -int -TclCompEvalObj( +ByteCode * +TclCompileObj( Tcl_Interp *interp, - Tcl_Obj *objPtr) + Tcl_Obj *objPtr, + const CmdFrame *invoker, + int word) { 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 - */ - - iPtr->numLevels++; - if (TclInterpReady(interp) == TCL_ERROR) { - iPtr->numLevels--; - return TCL_ERROR; - } - - if (iPtr->varFramePtr != NULL) { - namespacePtr = iPtr->varFramePtr->nsPtr; - } else { - namespacePtr = iPtr->globalNsPtr; - } + register ByteCode *codePtr; /* Tcl Internal type of bytecode. */ + Namespace *namespacePtr = iPtr->varFramePtr->nsPtr; /* * If the object is not already of tclByteCodeType, compile it (and reset @@ -991,16 +1714,7 @@ TclCompEvalObj( * compilation). Otherwise, check that it is "fresh" enough. */ - if (objPtr->typePtr != &tclByteCodeType) { - recompileObj: - iPtr->errorLine = 1; - result = tclByteCodeType.setFromAnyProc(interp, objPtr); - if (result != TCL_OK) { - iPtr->numLevels--; - return result; - } - codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr; - } else { + 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 @@ -1018,43 +1732,140 @@ TclCompEvalObj( * here. */ - codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr; + codePtr = objPtr->internalRep.twoPtrValue.ptr1; if (((Interp *) *codePtr->interpHandle != iPtr) || (codePtr->compileEpoch != iPtr->compileEpoch) -#ifdef CHECK_PROC_ORIGINATION /* [Bug: 3412 Pedantic] */ - || (codePtr->procPtr != NULL && !(iPtr->varFramePtr && - iPtr->varFramePtr->procPtr == codePtr->procPtr)) -#endif || (codePtr->nsPtr != namespacePtr) || (codePtr->nsEpoch != namespacePtr->resolverEpoch)) { - if (codePtr->flags & TCL_BYTECODE_PRECOMPILED) { - if ((Interp *) *codePtr->interpHandle != iPtr) { - Tcl_Panic("Tcl_EvalObj: compiled script jumped interps"); + if (!(codePtr->flags & TCL_BYTECODE_PRECOMPILED)) { + goto recompileObj; + } + if ((Interp *) *codePtr->interpHandle != iPtr) { + Tcl_Panic("Tcl_EvalObj: compiled script jumped interps"); + } + codePtr->compileEpoch = iPtr->compileEpoch; + } + + /* + * 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. + * + * But in 8.6 all the embedded script are compiled, and the resulting + * bytecode stored in the literal. Now the shared literal has bytecode + * with location data for _one_ particular location this literal is + * found at. If we get executed from a different location the bytecode + * has to be recompiled to get the correct locations. Not doing this + * will execute the saved bytecode with data for a different location, + * causing 'info frame' to point to the wrong place in the sources. + * + * Future optimizations ... + * (1) Save the location data (ExtCmdLoc) keyed by start line. In that + * case we recompile once per location of the literal, but not + * continously, because the moment we have all locations we do not + * need to recompile any longer. + * + * (2) Alternative: Do not recompile, tell the execution engine the + * offset between saved starting line and actual one. Then modify + * the users to adjust the locations they have by this offset. + * + * (3) Alternative 2: Do not fully recompile, adjust just the location + * information. + */ + + if (invoker == NULL) { + return codePtr; + } else { + Tcl_HashEntry *hePtr = + Tcl_FindHashEntry(iPtr->lineBCPtr, codePtr); + ExtCmdLoc *eclPtr; + CmdFrame *ctxCopyPtr; + int redo; + + if (!hePtr) { + return codePtr; + } + + eclPtr = Tcl_GetHashValue(hePtr); + redo = 0; + ctxCopyPtr = TclStackAlloc(interp, sizeof(CmdFrame)); + *ctxCopyPtr = *invoker; + + if (invoker->type == TCL_LOCATION_BC) { + /* + * Note: Type BC => ctx.data.eval.path is not used. + * ctx.data.tebc.codePtr used instead + */ + + TclGetSrcInfoForPc(ctxCopyPtr); + if (ctxCopyPtr->type == TCL_LOCATION_SOURCE) { + /* + * The reference made by 'TclGetSrcInfoForPc' is dead. + */ + + Tcl_DecrRefCount(ctxCopyPtr->data.eval.path); + ctxCopyPtr->data.eval.path = NULL; } - codePtr->compileEpoch = iPtr->compileEpoch; - } else { + } + + if (word < ctxCopyPtr->nline) { /* - * This byteCode is invalid: free it and recompile + * 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 ...). */ - objPtr->typePtr->freeIntRepProc(objPtr); - goto recompileObj; + + redo = ((eclPtr->type == TCL_LOCATION_SOURCE) + && (eclPtr->start != ctxCopyPtr->line[word])) + || ((eclPtr->type == TCL_LOCATION_BC) + && (ctxCopyPtr->type == TCL_LOCATION_SOURCE)); + } + + TclStackFree(interp, ctxCopyPtr); + if (!redo) { + return codePtr; } } } + recompileObj: + iPtr->errorLine = 1; + /* - * Increment the code's ref count while it is being executed. If - * afterwards no references to it remain, free the code. + * TIP #280. Remember the invoker for a moment in the interpreter + * structures so that the byte code compiler can pick it up when + * initializing the compilation environment, i.e. the extended location + * information. */ - codePtr->refCount++; - result = TclExecuteByteCode(interp, codePtr); - codePtr->refCount--; - if (codePtr->refCount <= 0) { - TclCleanupByteCode(codePtr); + iPtr->invokeCmdFramePtr = invoker; + iPtr->invokeWord = word; + TclSetByteCodeFromAny(interp, objPtr, NULL, NULL); + iPtr->invokeCmdFramePtr = NULL; + codePtr = objPtr->internalRep.twoPtrValue.ptr1; + if (iPtr->varFramePtr->localCachePtr) { + codePtr->localCachePtr = iPtr->varFramePtr->localCachePtr; + codePtr->localCachePtr->refCount++; } - iPtr->numLevels--; - return result; + return codePtr; } /* @@ -1088,36 +1899,51 @@ TclIncrObj( mp_int value, incr; if (Tcl_IsShared(valuePtr)) { - Tcl_Panic("shared object passed to TclIncrObj"); + Tcl_Panic("%s called with shared object", "TclIncrObj"); } if (GetNumberFromObj(NULL, valuePtr, &ptr1, &type1) != TCL_OK) { - /* Produce error message (reparse?!) */ - return Tcl_GetIntFromObj(interp, valuePtr, &type1); + /* + * Produce error message (reparse?!) + */ + + return TclGetIntFromObj(interp, valuePtr, &type1); } if (GetNumberFromObj(NULL, incrPtr, &ptr2, &type2) != TCL_OK) { - /* Produce error message (reparse?!) */ - Tcl_GetIntFromObj(interp, incrPtr, &type1); + /* + * Produce error message (reparse?!) + */ + + TclGetIntFromObj(interp, incrPtr, &type1); Tcl_AddErrorInfo(interp, "\n (reading increment)"); return TCL_ERROR; } if ((type1 == TCL_NUMBER_LONG) && (type2 == TCL_NUMBER_LONG)) { - long augend = *((CONST long *)ptr1); - long addend = *((CONST long *)ptr2); + long augend = *((const long *) ptr1); + long addend = *((const long *) ptr2); long sum = augend + addend; - /* Test for overflow */ - if ((augend >= 0 || addend >= 0 || sum < 0) - && (sum >= 0 || addend < 0 || augend < 0)) { + + /* + * 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 TCL_WIDE_INT_IS_LONG { - 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 */ + 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; } @@ -1125,32 +1951,42 @@ TclIncrObj( } if ((type1 == TCL_NUMBER_DOUBLE) || (type1 == TCL_NUMBER_NAN)) { - /* Produce error message (reparse?!) */ - return Tcl_GetIntFromObj(interp, valuePtr, &type1); + /* + * Produce error message (reparse?!) + */ + + return TclGetIntFromObj(interp, valuePtr, &type1); } - if ((type1 == TCL_NUMBER_DOUBLE) || (type1 == TCL_NUMBER_NAN)) { - /* Produce error message (reparse?!) */ - Tcl_GetIntFromObj(interp, incrPtr, &type1); + if ((type2 == TCL_NUMBER_DOUBLE) || (type2 == TCL_NUMBER_NAN)) { + /* + * Produce error message (reparse?!) + */ + + TclGetIntFromObj(interp, incrPtr, &type1); Tcl_AddErrorInfo(interp, "\n (reading increment)"); return TCL_ERROR; } -#ifndef NO_WIDE_TYPE +#ifndef TCL_WIDE_INT_IS_LONG if ((type1 != TCL_NUMBER_BIG) && (type2 != TCL_NUMBER_BIG)) { Tcl_WideInt w1, w2, sum; + TclGetWideIntFromObj(NULL, valuePtr, &w1); TclGetWideIntFromObj(NULL, incrPtr, &w2); sum = w1 + w2; - /* Check for overflow */ - if ((w1 >= 0 || w2 >= 0 || sum < 0) - && (w1 < 0 || w2 < 0 || sum >= 0)) { + + /* + * Check for overflow. + */ + + if (!Overflowing(w1, w2, sum)) { Tcl_SetWideIntObj(valuePtr, sum); return TCL_OK; } } #endif - Tcl_GetBignumAndClearObj(interp, valuePtr, &value); + Tcl_TakeBignumFromObj(interp, valuePtr, &value); Tcl_GetBignumFromObj(interp, incrPtr, &incr); mp_add(&value, &incr, &value); mp_clear(&incr); @@ -1161,7 +1997,42 @@ TclIncrObj( /* *---------------------------------------------------------------------- * - * TclExecuteByteCode -- + * 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, + int objc, + Tcl_Obj **objv) +{ + int cmd; + + if (GetSrcInfoForPc(pc, codePtr, NULL, NULL, &cmd)) { + TclArgumentBCEnter(interp, objv, objc, codePtr, &tdPtr->cmdFrame, cmd, + pc - codePtr->codeStart); + } +} + +/* + *---------------------------------------------------------------------- + * + * TclNRExecuteByteCode -- * * This procedure executes the instructions of a ByteCode structure. It * returns when a "done" instruction is executed or an error occurs. @@ -1176,12 +2047,82 @@ TclIncrObj( * *---------------------------------------------------------------------- */ +#define bcFramePtr (&TD->cmdFrame) +#define initCatchTop ((ptrdiff_t *) (&TD->stack[-1])) +#define initTosPtr ((Tcl_Obj **) (initCatchTop+codePtr->maxExceptDepth)) +#define esPtr (iPtr->execEnvPtr->execStackPtr) -static int -TclExecuteByteCode( +int +TclNRExecuteByteCode( Tcl_Interp *interp, /* Token for command interpreter. */ ByteCode *codePtr) /* The bytecode sequence to interpret. */ { + Interp *iPtr = (Interp *) interp; + TEBCdata *TD; + int size = sizeof(TEBCdata) - 1 + + (codePtr->maxStackDepth + codePtr->maxExceptDepth) + * sizeof(void *); + int numWords = (size + sizeof(Tcl_Obj *) - 1) / sizeof(Tcl_Obj *); + + codePtr->refCount++; + + /* + * Reserve the stack, setup the TEBCdataPtr (TD) and CallFrame + * + * The execution uses a unified stack: first a TEBCdata, immediately + * above it a CmdFrame, then the catch stack, then the execution stack. + * + * Make sure the catch stack is large enough to hold the maximum number of + * catch commands that could ever be executing at the same time (this will + * be no more than the exception range array's depth). Make sure the + * execution stack is large enough to execute this ByteCode. + */ + + TD = (TEBCdata *) GrowEvaluationStack(iPtr->execEnvPtr, numWords, 0); + esPtr->tosPtr = initTosPtr; + + TD->codePtr = codePtr; + TD->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 + + /* + * Push the callback for bytecode execution + */ + + TclNRAddCallback(interp, TEBCresume, TD, /* pc */ NULL, + /* cleanup */ INT2PTR(0), NULL); + return TCL_OK; +} + +static int +TEBCresume( + ClientData data[], + Tcl_Interp *interp, + int result) +{ /* * Compiler cast directive - not a real variable. * Interp *iPtr = (Interp *) interp; @@ -1189,103 +2130,160 @@ TclExecuteByteCode( #define iPtr ((Interp *) interp) /* - * Constants: variables that do not change during the execution, used - * sporadically. + * Check just the read-traced/write-traced bit of a variable. */ - ExecEnv *eePtr; /* Points to the execution environment. */ - int initStackTop; /* Stack top at start of execution. */ - int initCatchTop; /* Catch stack top at start of execution. */ - Var *compiledLocals; - Namespace *namespacePtr; +#define ReadTraced(varPtr) ((varPtr)->flags & VAR_TRACED_READ) +#define WriteTraced(varPtr) ((varPtr)->flags & VAR_TRACED_WRITE) +#define UnsetTraced(varPtr) ((varPtr)->flags & VAR_TRACED_UNSET) /* - * Globals: variables that store state, must remain valid at all times. + * Bottom of allocated stack holds the NR data + */ + + /* + * Constants: variables that do not change during the execution, used + * sporadically: no special need for speed. */ - int catchTop; - register Tcl_Obj **tosPtr; /* Cached pointer to top of evaluation stack. */ - 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 DECACHE_STACK_INFO() */ + const char *curInstName; +#ifdef TCL_COMPILE_DEBUG + int traceInstructions; /* Whether we are doing instruction-level + * tracing or not. */ +#endif + + Var *compiledLocals = iPtr->varFramePtr->compiledLocals; + Tcl_Obj **constants = &iPtr->execEnvPtr->constants[0]; + +#define LOCAL(i) (&compiledLocals[(i)]) +#define TCONST(i) (constants[(i)]) /* - * Transfer variables - needed only between opcodes, but not while - * executing an instruction. + * These macros are just meant to save some global variables that are not + * used too frequently */ - register int cleanup; - Tcl_Obj *objResultPtr; + TEBCdata *TD = data[0]; +#define auxObjList (TD->auxObjList) +#define catchTop (TD->catchTop) +#define codePtr (TD->codePtr) /* - * Result variable - needed only when going to checkForcatch or other - * error handlers; also used as local in some opcodes. + * Globals: variables that store state, must remain valid at all times. */ - int result = TCL_OK; /* Return code returned after execution. */ + Tcl_Obj **tosPtr; /* Cached pointer to top of evaluation + * stack. */ + const unsigned char *pc = data[1]; + /* The current program counter. */ + unsigned char inst; /* The currently running instruction */ + + /* + * Transfer variables - needed only between opcodes, but not while + * executing an instruction. + */ + + int cleanup = PTR2INT(data[2]); + Tcl_Obj *objResultPtr; + int checkInterp; /* Indicates when a check of interp readyness + * is necessary. Set by CACHE_STACK_INFO() */ /* * Locals - variables that are used within opcodes or bounded sections of * the file (jumps between opcodes within a family). - * NOTE: These are now defined locally where needed. + * NOTE: These are now mostly defined locally where needed. */ + Tcl_Obj *objPtr, *valuePtr, *value2Ptr, *part1Ptr, *part2Ptr, *tmpPtr; + Tcl_Obj **objv; + int objc = 0; + int opnd, length, pcAdjustment; + Var *varPtr, *arrayPtr; #ifdef TCL_COMPILE_DEBUG - int traceInstructions = (tclTraceExec == 3); char cmdNameBuf[21]; #endif - /* - * The execution uses a unified stack: first the catch stack, immediately - * above it 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. - */ - - eePtr = iPtr->execEnvPtr; - initCatchTop = eePtr->tosPtr - eePtr->stackPtr; - catchTop = initCatchTop; - tosPtr = eePtr->tosPtr + codePtr->maxExceptDepth; +#ifdef TCL_COMPILE_DEBUG + int starting = 1; + traceInstructions = (tclTraceExec == 3); +#endif - while ((tosPtr + codePtr->maxStackDepth) > eePtr->endPtr) { - GrowEvaluationStack(eePtr); - tosPtr = eePtr->tosPtr + codePtr->maxExceptDepth; - } - initStackTop = tosPtr - eePtr->stackPtr; + TEBC_DATA_DIG(); #ifdef TCL_COMPILE_DEBUG - if (tclTraceExec >= 2) { + if (!pc && (tclTraceExec >= 2)) { PrintByteCodeInfo(codePtr); - fprintf(stdout, " Starting stack top=%d\n", initStackTop); + fprintf(stdout, " Starting stack top=%d\n", (int) CURR_DEPTH); fflush(stdout); } #endif -#ifdef TCL_COMPILE_STATS - iPtr->stats.numExecutions++; -#endif - - if (iPtr->varFramePtr != NULL) { - namespacePtr = iPtr->varFramePtr->nsPtr; - compiledLocals = iPtr->varFramePtr->compiledLocals; + if (!pc) { + /* bytecode is starting from scratch */ + checkInterp = 0; + pc = codePtr->codeStart; + goto cleanup0; } else { - namespacePtr = iPtr->globalNsPtr; - compiledLocals = NULL; - } + /* resume from invocation */ + CACHE_STACK_INFO(); + if (iPtr->execEnvPtr->rewind) { + result = TCL_ERROR; + goto abnormalReturn; + } - /* - * Loop executing instructions until a "done" instruction, a TCL_RETURN, - * or some error. - */ + 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 (codePtr->flags & TCL_BYTECODE_RECOMPILE) { + iPtr->flags |= ERR_ALREADY_LOGGED; + codePtr->flags &= ~TCL_BYTECODE_RECOMPILE; + } - goto cleanup0; + if (result != TCL_OK) { + pc--; + goto processExceptionReturn; + } + + /* + * Push the call's object result and continue execution with the next + * instruction. + */ + + TRACE_WITH_OBJ(("%u => ... after \"%.20s\": TCL_OK, result=", + objc, cmdNameBuf), Tcl_GetObjResult(interp)); + + /* + * 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. + */ + + 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); + } /* * Targets for standard instruction endings; unrolled for speed in the @@ -1296,75 +2294,54 @@ TclExecuteByteCode( * cleanup. */ - { - 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 = *tosPtr; - TclDecrRefCount(valuePtr); - } - *tosPtr = objResultPtr; + cleanupV_pushObjResultPtr: + switch (cleanup) { + case 0: + *(++tosPtr) = (objResultPtr); goto cleanup0; - - 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; + default: + cleanup -= 2; + while (cleanup--) { + objPtr = POP_OBJECT(); + TclDecrRefCount(objPtr); } + case 2: + cleanup2_pushObjResultPtr: + objPtr = POP_OBJECT(); + TclDecrRefCount(objPtr); + case 1: + cleanup1_pushObjResultPtr: + objPtr = OBJ_AT_TOS; + TclDecrRefCount(objPtr); } - cleanup0: + OBJ_AT_TOS = objResultPtr; + goto cleanup0; -#ifdef TCL_COMPILE_DEBUG - /* - * Skip the stack depth check if an expansion is in progress - */ + cleanupV: + switch (cleanup) { + default: + cleanup -= 2; + while (cleanup--) { + objPtr = POP_OBJECT(); + TclDecrRefCount(objPtr); + } + case 2: + cleanup2: + objPtr = POP_OBJECT(); + TclDecrRefCount(objPtr); + case 1: + cleanup1: + objPtr = POP_OBJECT(); + TclDecrRefCount(objPtr); + case 0: + /* + * We really want to do nothing now, but this is needed for some + * compilers (SunPro CC). + */ - ValidatePcAndStackTop(codePtr, pc, (tosPtr - eePtr->stackPtr), - initStackTop, /*checkStack*/ (expandNestList == NULL)); - if (traceInstructions) { - fprintf(stdout, "%2d: %2d ", iPtr->numLevels, (tosPtr - eePtr->stackPtr)); - TclPrintInstruction(codePtr, pc); - fflush(stdout); + break; } -#endif /* TCL_COMPILE_DEBUG */ - -#ifdef TCL_COMPILE_STATS - iPtr->stats.instructionCount[*pc]++; -#endif + cleanup0: /* * Check for asynchronous handlers [Bug 746722]; we do the check every @@ -1372,223 +2349,422 @@ TclExecuteByteCode( */ if ((instructionCount++ & ASYNC_CHECK_COUNT_MASK) == 0) { - if (Tcl_AsyncReady()) { - int localResult; + DECACHE_STACK_INFO(); + if (TclAsyncReady(iPtr)) { + result = Tcl_AsyncInvoke(interp, result); + if (result == 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 (TclCanceled(iPtr)) { + if (Tcl_Canceled(interp, TCL_LEAVE_ERR_MSG) == TCL_ERROR) { + CACHE_STACK_INFO(); + goto gotError; } } - if (Tcl_LimitReady(interp)) { - int localResult; - DECACHE_STACK_INFO(); - localResult = Tcl_LimitCheck(interp); - 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; } } + CACHE_STACK_INFO(); + } + + /* + * These two instructions account for 26% of all instructions (according + * to measurements on tclbench by Ben Vitale + * [http://www.cs.toronto.edu/syslab/pubs/tcl2005-vitale-zaleski.pdf] + * Resolving them before the switch reduces the cost of branch + * mispredictions, seems to improve runtime by 5% to 15%, and (amazingly!) + * reduces total obj size. + */ + + 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, "%2d: %2d ", iPtr->numLevels, (int) CURR_DEPTH); + TclPrintInstruction(codePtr, pc); + fflush(stdout); } +#endif /* TCL_COMPILE_DEBUG */ - switch (*pc) { + TCL_DTRACE_INST_NEXT(); + + if (inst == 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) { + checkInterp = 0; + if (((codePtr->compileEpoch != iPtr->compileEpoch) || + (codePtr->nsEpoch != iPtr->varFramePtr->nsPtr->resolverEpoch)) && + !(codePtr->flags & TCL_BYTECODE_PRECOMPILED)) { + goto instStartCmdFailed; + } + } + inst = *(pc += 9); + goto peepholeStart; + } else if (inst == INST_NOP) { +#ifndef TCL_COMPILE_DEBUG + while (inst == INST_NOP) +#endif + { + inst = *++pc; + } + goto peepholeStart; + } + + switch (inst) { + case INST_SYNTAX: case INST_RETURN_IMM: { int code = TclGetInt4AtPtr(pc+1); int level = TclGetUInt4AtPtr(pc+5); - Tcl_Obj *returnOpts; + + /* + * OBJ_AT_TOS is returnOpts, OBJ_UNDER_TOS is resultObjPtr. + */ TRACE(("%u %u => ", code, level)); - returnOpts = POP_OBJECT(); - result = TclProcessReturn(interp, code, level, returnOpts); - Tcl_DecrRefCount(returnOpts); - if (result != TCL_OK) { - Tcl_SetObjResult(interp, *tosPtr); - cleanup = 1; - goto processExceptionReturn; + result = TclProcessReturn(interp, code, level, OBJ_AT_TOS); + if (result == TCL_OK) { + TRACE_APPEND(("continuing to next instruction (result=\"%.30s\")\n", + O2S(objResultPtr))); + NEXT_INST_F(9, 1, 0); } - TRACE_APPEND(("continuing to next instruction (result=\"%.30s\")", - O2S(objResultPtr))); - NEXT_INST_F(9, 0, 0); + 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, POP_OBJECT()); - if (result != TCL_OK) { + result = Tcl_SetReturnOptions(interp, OBJ_AT_TOS); + if (result == TCL_OK) { + Tcl_DecrRefCount(OBJ_AT_TOS); + OBJ_AT_TOS = objResultPtr; + TRACE_APPEND(("continuing to next instruction (result=\"%.30s\")\n", + 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); - Tcl_DecrRefCount(objResultPtr); - cleanup = 0; - goto processExceptionReturn; } - TRACE_APPEND(("continuing to next instruction (result=\"%.30s\")", - O2S(objResultPtr))); - NEXT_INST_F(1, 0, -1); + cleanup = 1; + TRACE_APPEND(("\n")); + goto processExceptionReturn; - case INST_DONE: - if (tosPtr <= eePtr->stackPtr + initStackTop) { - tosPtr--; - goto abnormalReturn; + { + CoroutineData *corPtr; + int 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", + NULL); + CACHE_STACK_INFO(); + goto gotError; } - /* - * Set the interpreter's object result to point to the topmost object - * from the stack, and check for a possible [catch]. The stackTop's - * level and refCount will be handled by "processCatch" or - * "abnormalReturn". - */ - - Tcl_SetObjResult(interp, *tosPtr); #ifdef TCL_COMPILE_DEBUG - TRACE_WITH_OBJ(("=> return code=%d, result=", result), - iPtr->objResultPtr); - if (traceInstructions) { - fprintf(stdout, "\n"); + if (tclTraceExec >= 2) { + if (traceInstructions) { + TRACE_APPEND(("YIELD...\n")); + } else { + fprintf(stdout, "%d: (%u) yielding value \"%.30s\"\n", + iPtr->numLevels, (unsigned)(pc - codePtr->codeStart), + Tcl_GetString(OBJ_AT_TOS)); + } + fflush(stdout); } #endif - goto checkForCatch; + yieldParameter = 0; + 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", + 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", + NULL); + CACHE_STACK_INFO(); + goto gotError; + } - case INST_PUSH1: -#if !TCL_COMPILE_DEBUG - instPush1Peephole: +#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, "%d: (%u) yielding to [%.30s]\n", + iPtr->numLevels, (unsigned)(pc - codePtr->codeStart), + Tcl_GetString(valuePtr)); + } + fflush(stdout); + } #endif - PUSH_OBJECT(codePtr->objArrayPtr[TclGetUInt1AtPtr(pc+1)]); - TRACE_WITH_OBJ(("%u => ", TclGetInt1AtPtr(pc+1)), *tosPtr); - pc += 2; -#if !TCL_COMPILE_DEBUG + /* - * Runtime peephole optimisation: check if we are pushing again. + * Install a tailcall record in the caller and continue with the + * yield. The yield is switched into multi-return mode (via the + * 'yieldParameter'). + */ + + Tcl_IncrRefCount(valuePtr); + iPtr->execEnvPtr = corPtr->callerEEPtr; + TclSetTailcall(interp, valuePtr); + iPtr->execEnvPtr = corPtr->eePtr; + yieldParameter = (PTR2INT(NULL)+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 (*pc == INST_PUSH1) { - goto instPush1Peephole; + if (iPtr->flags & INTERP_DEBUG_FRAME) { + ArgumentBCEnter(interp, codePtr, TD, pc, objc, objv); } -#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); + pc++; + cleanup = 1; + TEBC_YIELD(); + TclNRAddCallback(interp, TclNRCoroutineActivateCallback, corPtr, + INT2PTR(yieldParameter), NULL, NULL); + return TCL_OK; + } - case INST_POP: { - Tcl_Obj *valuePtr; + case INST_TAILCALL: { + Tcl_Obj *listPtr, *nsObjPtr; - TRACE_WITH_OBJ(("=> discarding "), *tosPtr); - valuePtr = POP_OBJECT(); - TclDecrRefCount(valuePtr); + opnd = TclGetUInt1AtPtr(pc+1); - /* - * 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. - */ + 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", NULL); + CACHE_STACK_INFO(); + goto gotError; + } - pc++; -#if !TCL_COMPILE_DEBUG - if (*pc == INST_START_CMD) { - goto instStartCmdPeephole; +#ifdef TCL_COMPILE_DEBUG + /* FIXME: What is the right thing to trace? */ + { + register 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 - 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. + * Push the evaluation of the called command into the NR callback + * stack. */ - iPtr->cmdCount++; - if (!checkInterp || - (((codePtr->compileEpoch == iPtr->compileEpoch) - && (codePtr->nsEpoch == namespacePtr->resolverEpoch)) - || (codePtr->flags & TCL_BYTECODE_PRECOMPILED))) { -#if !TCL_COMPILE_DEBUG + 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) { /* - * Peephole optimisations: check if there are several - * INST_START_CMD in a row. Many commands start by pushing a - * literal argument or command name; optimise that case too. + * Set the interpreter's object result to point to the topmost + * object from the stack, and check for a possible [catch]. The + * stackTop's level and refCount will be handled by "processCatch" + * or "abnormalReturn". */ - while (*(pc += 5) == INST_START_CMD) { - iPtr->cmdCount++; - } - if (*pc == INST_PUSH1) { - goto instPush1Peephole; + Tcl_SetObjResult(interp, OBJ_AT_TOS); +#ifdef TCL_COMPILE_DEBUG + TRACE_WITH_OBJ(("=> return code=%d, result=", result), + iPtr->objResultPtr); + if (traceInstructions) { + fprintf(stdout, "\n"); } - NEXT_INST_F(0, 0, 0); -#else - NEXT_INST_F(5, 0, 0); #endif - } else { - 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; - goto processExceptionReturn; - } - opnd = TclGetUInt4AtPtr(pc+1); - objResultPtr = Tcl_GetObjResult(interp); - TclNewObj(newObjResultPtr); - Tcl_IncrRefCount(newObjResultPtr); - iPtr->objResultPtr = newObjResultPtr; - NEXT_INST_V(opnd, 0, -1); + goto checkForCatch; } + (void) POP_OBJECT(); + goto abnormalReturn; + + case INST_PUSH4: + objResultPtr = codePtr->objArrayPtr[TclGetUInt4AtPtr(pc+1)]; + TRACE_WITH_OBJ(("%u => ", TclGetUInt4AtPtr(pc+1)), objResultPtr); + NEXT_INST_F(5, 0, 1); + + case INST_POP: + TRACE_WITH_OBJ(("=> discarding "), OBJ_AT_TOS); + objPtr = POP_OBJECT(); + TclDecrRefCount(objPtr); + NEXT_INST_F(1, 0, 0); case INST_DUP: - objResultPtr = *tosPtr; + objResultPtr = OBJ_AT_TOS; TRACE_WITH_OBJ(("=> "), objResultPtr); NEXT_INST_F(1, 0, 1); - case INST_OVER: { - int opnd; - + case INST_OVER: opnd = TclGetUInt4AtPtr(pc+1); - objResultPtr = *(tosPtr - opnd); - TRACE_WITH_OBJ(("=> "), objResultPtr); + objResultPtr = OBJ_AT_DEPTH(opnd); + TRACE_WITH_OBJ(("%u => ", opnd), objResultPtr); NEXT_INST_F(5, 0, 1); + + case INST_REVERSE: { + Tcl_Obj **a, **b; + + opnd = TclGetUInt4AtPtr(pc+1); + a = tosPtr-(opnd-1); + b = tosPtr; + while (a<b) { + tmpPtr = *a; + *a = *b; + *b = tmpPtr; + a++; b--; + } + TRACE(("%u => OK\n", opnd)); + NEXT_INST_F(5, 0, 0); } - case INST_CONCAT1: { - int opnd, length, appendLen = 0; + case INST_STR_CONCAT1: { + int appendLen = 0; char *bytes, *p; Tcl_Obj **currPtr; + int onlyb = 1; opnd = TclGetUInt1AtPtr(pc+1); /* + * Detect only-bytearray-or-null case. + */ + + for (currPtr=&OBJ_AT_DEPTH(opnd-1); currPtr<=&OBJ_AT_TOS; currPtr++) { + if (((*currPtr)->typePtr != &tclByteArrayType) + && ((*currPtr)->bytes != tclEmptyStringRep)) { + onlyb = 0; + break; + } else if (((*currPtr)->typePtr == &tclByteArrayType) && + ((*currPtr)->bytes != NULL)) { + onlyb = 0; + break; + } + } + + /* * Compute the length to be appended. */ - for (currPtr = tosPtr - (opnd-2); currPtr <= tosPtr; currPtr++) { - bytes = Tcl_GetStringFromObj(*currPtr, &length); - if (bytes != NULL) { - appendLen += length; + if (onlyb) { + for (currPtr = &OBJ_AT_DEPTH(opnd-2); + appendLen >= 0 && currPtr <= &OBJ_AT_TOS; currPtr++) { + if ((*currPtr)->bytes != tclEmptyStringRep) { + Tcl_GetByteArrayFromObj(*currPtr, &length); + appendLen += length; + } + } + } else { + for (currPtr = &OBJ_AT_DEPTH(opnd-2); + appendLen >= 0 && currPtr <= &OBJ_AT_TOS; currPtr++) { + bytes = TclGetStringFromObj(*currPtr, &length); + if (bytes != NULL) { + appendLen += length; + } } } + if (appendLen < 0) { + /* TODO: convert panic to error ? */ + Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); + } + /* * If nothing is to be appended, just return the first object by * dropping all the others from the stack; this saves both the * computation and copy of the string rep of the first object, - * enabling the fast '$x[set x {}]' idiom for 'K $x [set x{}]'. + * enabling the fast '$x[set x {}]' idiom for 'K $x [set x {}]'. */ if (appendLen == 0) { @@ -1600,52 +2776,104 @@ TclExecuteByteCode( * 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 already copied by - * Tcl_SetObjectLength, 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 = *(tosPtr-(opnd-1)); - bytes = Tcl_GetStringFromObj(objResultPtr, &length); -#if !TCL_COMPILE_DEBUG - if (!Tcl_IsShared(objResultPtr)) { - Tcl_SetObjLength(objResultPtr, (length + appendLen)); - p = TclGetString(objResultPtr) + length; - currPtr = tosPtr - (opnd - 2); - } else { + * if it is unshared its bytes are copied by ckrealloc, so that we set + * the loop parameters to avoid copying them again: p points to the + * end of the already copied bytes, currPtr to the second object. + */ + + objResultPtr = OBJ_AT_DEPTH(opnd-1); + if (!onlyb) { + bytes = TclGetStringFromObj(objResultPtr, &length); + if (length + appendLen < 0) { + /* TODO: convert panic to error ? */ + Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", + INT_MAX); + } +#ifndef TCL_COMPILE_DEBUG + if (bytes != tclEmptyStringRep && !Tcl_IsShared(objResultPtr)) { + TclFreeIntRep(objResultPtr); + objResultPtr->bytes = ckrealloc(bytes, length+appendLen+1); + objResultPtr->length = length + appendLen; + p = TclGetString(objResultPtr) + length; + currPtr = &OBJ_AT_DEPTH(opnd - 2); + } else #endif - p = (char *) ckalloc((unsigned) (length + appendLen + 1)); - TclNewObj(objResultPtr); - objResultPtr->bytes = p; - objResultPtr->length = length + appendLen; - currPtr = tosPtr - (opnd - 1); -#if !TCL_COMPILE_DEBUG - } + { + p = ckalloc(length + appendLen + 1); + TclNewObj(objResultPtr); + objResultPtr->bytes = p; + objResultPtr->length = length + appendLen; + currPtr = &OBJ_AT_DEPTH(opnd - 1); + } + + /* + * 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'; + } else { + bytes = (char *) Tcl_GetByteArrayFromObj(objResultPtr, &length); + if (length + appendLen < 0) { + /* TODO: convert panic to error ? */ + Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", + INT_MAX); + } +#ifndef TCL_COMPILE_DEBUG + if (!Tcl_IsShared(objResultPtr)) { + bytes = (char *) Tcl_SetByteArrayLength(objResultPtr, + length + appendLen); + p = bytes + length; + currPtr = &OBJ_AT_DEPTH(opnd - 2); + } else #endif + { + TclNewObj(objResultPtr); + bytes = (char *) Tcl_SetByteArrayLength(objResultPtr, + length + appendLen); + p = bytes; + currPtr = &OBJ_AT_DEPTH(opnd - 1); + } - /* - * Append the remaining characters. - */ + /* + * Append the remaining characters. + */ - for (; currPtr <= tosPtr; currPtr++) { - bytes = Tcl_GetStringFromObj(*currPtr, &length); - if (bytes != NULL) { - memcpy((VOID *) p, (VOID *) bytes, (size_t) length); - p += length; + for (; currPtr <= &OBJ_AT_TOS; currPtr++) { + if ((*currPtr)->bytes != tclEmptyStringRep) { + bytes = (char *) Tcl_GetByteArrayFromObj(*currPtr,&length); + memcpy(p, bytes, (size_t) length); + p += length; + } } } - *p = '\0'; TRACE_WITH_OBJ(("%u => ", opnd), objResultPtr); NEXT_INST_V(2, opnd, 1); } - case INST_EXPAND_START: { + case INST_CONCAT_STK: /* - * Push an element to the expandNestList. This records the current - * tosPtr - i.e., the point in the stack where the expanded command - * starts. + * Pop the opnd (objc) top stack elements, run through Tcl_ConcatObj, + * and then decrement their ref counts. + */ + + opnd = TclGetUInt4AtPtr(pc+1); + objResultPtr = Tcl_ConcatObj(opnd, &OBJ_AT_DEPTH(opnd-1)); + TRACE_WITH_OBJ(("%u => ", opnd), objResultPtr); + NEXT_INST_V(5, opnd, 1); + + case INST_EXPAND_START: + /* + * Push an element to the auxObjList. This records the current + * stack depth - i.e., the point in the stack where the expanded + * command starts. * * Use a Tcl_Obj as linked list element; slight mem waste, but faster * allocation than ckalloc. This also abuses the Tcl_Obj structure, as @@ -1655,91 +2883,135 @@ TclExecuteByteCode( * error, also in INST_EXPAND_STKTOP). */ - Tcl_Obj *objPtr; - TclNewObj(objPtr); - objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) - (tosPtr - eePtr->stackPtr); - objPtr->internalRep.twoPtrValue.ptr2 = (VOID *) expandNestList; - expandNestList = objPtr; + objPtr->internalRep.ptrAndLongRep.value = CURR_DEPTH; + objPtr->length = 0; + PUSH_TAUX_OBJ(objPtr); + TRACE(("=> mark depth as %d\n", (int) CURR_DEPTH)); NEXT_INST_F(1, 0, 0); - } + + 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 - auxObjList->internalRep.ptrAndLongRep.value; + POP_TAUX_OBJ(); +#ifdef TCL_COMPILE_DEBUG + /* Ugly abuse! */ + starting = 1; +#endif + TRACE(("=> drop %d items\n", objc)); + NEXT_INST_V(1, objc, 0); case INST_EXPAND_STKTOP: { - int objc, length, i; - Tcl_Obj **objv, *valuePtr, *objPtr; + int i; + ptrdiff_t moved; /* - * Make sure that the element at stackTop is a list; if not, remove - * the element from the expand link list and leave. + * Make sure that the element at stackTop is a list; if not, just + * leave with an error. Note that the element from the expand list + * will be removed at checkForCatch. */ - valuePtr = *tosPtr; - if (Tcl_ListObjGetElements(interp, valuePtr, &objc, &objv) != TCL_OK) { - result = TCL_ERROR; - TRACE_WITH_OBJ(("%.30s => ERROR: ", O2S(valuePtr)), - Tcl_GetObjResult(interp)); - objPtr = expandNestList; - expandNestList = (Tcl_Obj *) objPtr->internalRep.twoPtrValue.ptr2; - TclDecrRefCount(objPtr); - goto checkForCatch; + objPtr = OBJ_AT_TOS; + TRACE(("\"%.30s\" => ", O2S(objPtr))); + if (TclListObjGetElements(interp, objPtr, &objc, &objv) != TCL_OK) { + TRACE_ERROR(interp); + goto gotError; } - tosPtr--; + (void) POP_OBJECT(); /* * Make sure there is enough room in the stack to expand this list * *and* process the rest of the command (at least up to the next - * argument expansion or command end). The operand is the current + * argument expansion or command end). The operand is the current * stack depth, as seen by the compiler. */ - length = objc + codePtr->maxStackDepth - TclGetInt4AtPtr(pc+1); - while ((tosPtr + length) > eePtr->endPtr) { + 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(); - GrowEvaluationStack(eePtr); - CACHE_STACK_INFO(); + moved = GrowEvaluationStack(iPtr->execEnvPtr, length, 1) + - (Tcl_Obj **) TD; + if (moved) { + /* + * Change the global data to point to the new stack: move the + * TEBCdataPtr TD, recompute the position of every other + * stack-allocated parameter, update the stack pointers. + */ + + esPtr = iPtr->execEnvPtr->execStackPtr; + TD = (TEBCdata *) (((Tcl_Obj **)TD) + moved); + + catchTop += moved; + tosPtr += moved; + } } /* - * Expand the list at stacktop onto the stack; free the list. + * Expand the list at stacktop onto the stack; free the list. Knowing + * that it has a freeIntRepProc we use Tcl_DecrRefCount(). */ for (i = 0; i < objc; i++) { PUSH_OBJECT(objv[i]); } - TclDecrRefCount(valuePtr); + + TRACE_APPEND(("OK\n")); + Tcl_DecrRefCount(objPtr); NEXT_INST_F(5, 0, 0); } - { + 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 */ - int objc, pcAdjustment; + instEvalStk: + case INST_EVAL_STK: + bcFramePtr->data.tebc.pc = (char *) pc; + iPtr->cmdFramePtr = bcFramePtr; - case INST_INVOKE_EXPANDED: - { - Tcl_Obj *objPtr; + cleanup = 1; + pc += 1; + TEBC_YIELD(); + return TclNREvalObjEx(interp, OBJ_AT_TOS, 0, NULL, 0); - objPtr = expandNestList; - expandNestList = (Tcl_Obj *) objPtr->internalRep.twoPtrValue.ptr2; - objc = tosPtr - eePtr->stackPtr - - (ptrdiff_t) objPtr->internalRep.twoPtrValue.ptr1; - TclDecrRefCount(objPtr); + case INST_INVOKE_EXPANDED: + CLANG_ASSERT(auxObjList); + objc = CURR_DEPTH - auxObjList->internalRep.ptrAndLongRep.value; + POP_TAUX_OBJ(); + if (objc) { + pcAdjustment = 1; + goto doInvocation; } - if (objc == 0) { - /* - * Nothing was expanded, return {}. - */ - - TclNewObj(objResultPtr); - NEXT_INST_F(1, 0, 1); - } + /* + * Nothing was expanded, return {}. + */ - pcAdjustment = 1; - goto doInvocation; + TclNewObj(objResultPtr); + NEXT_INST_F(1, 0, 1); case INST_INVOKE_STK4: objc = TclGetUInt4AtPtr(pc+1); @@ -1751,224 +3023,211 @@ TclExecuteByteCode( pcAdjustment = 2; doInvocation: - { - Tcl_Obj **objv = (tosPtr - (objc-1)); - int length; - char *bytes; - - /* - * We keep the stack reference count as a (char *), as that works - * nicely as a portable pointer-sized counter. - */ - - char **preservedStackRefCountPtr; + objv = &OBJ_AT_DEPTH(objc-1); + cleanup = objc; #ifdef TCL_COMPILE_DEBUG - if (tclTraceExec >= 2) { - int i; - - if (traceInstructions) { - strncpy(cmdNameBuf, TclGetString(objv[0]), 20); - TRACE(("%u => call ", objc)); - } else { - fprintf(stdout, "%d: (%u) invoking ", iPtr->numLevels, - (unsigned int)(pc - codePtr->codeStart)); - } - for (i = 0; i < objc; i++) { - TclPrintObject(stdout, objv[i], 15); - fprintf(stdout, " "); - } - fprintf(stdout, "\n"); - fflush(stdout); - } -#endif /*TCL_COMPILE_DEBUG*/ - - /* - * If trace procedures will be called, we need a command string to - * pass to TclEvalObjvInternal; note that a copy of the string - * will be made there to include the ending \0. - */ + if (tclTraceExec >= 2) { + int i; - bytes = NULL; - length = 0; - if (iPtr->tracePtr != NULL) { - Trace *tracePtr, *nextTracePtr; - - for (tracePtr = iPtr->tracePtr; tracePtr != NULL; - tracePtr = nextTracePtr) { - nextTracePtr = tracePtr->nextPtr; - if (tracePtr->level == 0 || - iPtr->numLevels <= tracePtr->level) { - /* - * Traces will be called: get command string - */ - - bytes = GetSrcInfoForPc(pc, codePtr, &length); - break; - } - } + if (traceInstructions) { + strncpy(cmdNameBuf, TclGetString(objv[0]), 20); + TRACE(("%u => call ", objc)); } else { - Command *cmdPtr; - - cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, objv[0]); - if ((cmdPtr!=NULL) && (cmdPtr->flags & CMD_HAS_EXEC_TRACES)) { - bytes = GetSrcInfoForPc(pc, codePtr, &length); - } + 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); + } +#endif /*TCL_COMPILE_DEBUG*/ - /* - * A reference to part of the stack vector itself escapes our - * control: increase its refCount to stop it from being - * deallocated by a recursive call to ourselves. The extra - * variable is needed because all others are liable to change due - * to the trace procedures. - */ - - preservedStackRefCountPtr = (char **) (eePtr->stackPtr-1); - ++*preservedStackRefCountPtr; - - /* - * Reset the instructionCount variable, since we're about to check - * for async stuff anyway while processing TclEvalObjvInternal. - */ - - instructionCount = 1; + /* + * Finally, let TclEvalObjv handle the command. + * + * TIP #280: Record the last piece of info needed by + * 'TclGetSrcInfoForPc', and push the frame. + */ - /* - * Finally, let TclEvalObjvInternal handle the command. - */ + bcFramePtr->data.tebc.pc = (char *) pc; + iPtr->cmdFramePtr = bcFramePtr; - DECACHE_STACK_INFO(); - Tcl_ResetResult(interp); - result = TclEvalObjvInternal(interp, objc, objv, bytes, length, 0); - CACHE_STACK_INFO(); + if (iPtr->flags & INTERP_DEBUG_FRAME) { + ArgumentBCEnter(interp, codePtr, TD, pc, objc, objv); + } - /* - * If the old stack is going to be released, it is safe to do so - * now, since no references to objv are going to be used from now - * on. - */ + DECACHE_STACK_INFO(); - --*preservedStackRefCountPtr; - if (*preservedStackRefCountPtr == (char *) 0) { - ckfree((VOID *) preservedStackRefCountPtr); - } + pc += pcAdjustment; + TEBC_YIELD(); + return TclNREvalObjv(interp, objc, objv, + TCL_EVAL_NOERR | TCL_EVAL_SOURCE_IN_FRAME, NULL); - if (result == TCL_OK) { - Tcl_Obj *objPtr; - /* - * Push the call's object result and continue execution with - * the next instruction. - */ +#if TCL_SUPPORT_84_BYTECODE + case INST_CALL_BUILTIN_FUNC1: + /* + * Call one of the built-in pre-8.5 Tcl math functions. This + * translates to INST_INVOKE_STK1 with the first argument of + * ::tcl::mathfunc::$objv[0]. We need to insert the named math + * function into the stack. + */ - TRACE_WITH_OBJ(("%u => ... after \"%.20s\": TCL_OK, result=", - objc, cmdNameBuf), Tcl_GetObjResult(interp)); + 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); + } - objResultPtr = Tcl_GetObjResult(interp); + TclNewLiteralStringObj(objPtr, "::tcl::mathfunc::"); + Tcl_AppendToObj(objPtr, tclBuiltinFuncTable[opnd].name, -1); - /* - * 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. - */ + /* + * Only 0, 1 or 2 args. + */ - TclNewObj(objPtr); - Tcl_IncrRefCount(objPtr); - iPtr->objResultPtr = objPtr; - NEXT_INST_V(pcAdjustment, objc, -1); + { + int numArgs = tclBuiltinFuncTable[opnd].numArgs; + Tcl_Obj *tmpPtr1, *tmpPtr2; + + if (numArgs == 0) { + PUSH_OBJECT(objPtr); + } else if (numArgs == 1) { + tmpPtr1 = POP_OBJECT(); + PUSH_OBJECT(objPtr); + PUSH_OBJECT(tmpPtr1); + Tcl_DecrRefCount(tmpPtr1); } else { - cleanup = objc; - goto processExceptionReturn; + 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_EVAL_STK: { + case INST_CALL_FUNC1: /* - * Note to maintainers: it is important that INST_EVAL_STK pop its - * argument from the stack before jumping to checkForCatch! DO NOT - * OPTIMISE! + * Call a non-builtin Tcl math function previously registered by a + * call to Tcl_CreateMathFunc pre-8.5. This is essentially + * INST_INVOKE_STK1 converting the first arg to + * ::tcl::mathfunc::$objv[0]. */ - Tcl_Obj *objPtr; + objc = TclGetUInt1AtPtr(pc+1); /* Number of arguments. The function + * name is the 0-th argument. */ - objPtr = *tosPtr; - DECACHE_STACK_INFO(); - result = TclCompEvalObj(interp, objPtr); - CACHE_STACK_INFO(); - if (result == TCL_OK) { - /* - * Normal return; push the eval's object result. - */ + objPtr = OBJ_AT_DEPTH(objc-1); + TclNewLiteralStringObj(tmpPtr, "::tcl::mathfunc::"); + Tcl_AppendObjToObj(tmpPtr, objPtr); + Tcl_DecrRefCount(objPtr); - objResultPtr = Tcl_GetObjResult(interp); - TRACE_WITH_OBJ(("\"%.30s\" => ", O2S(objPtr)), - Tcl_GetObjResult(interp)); + /* + * Variation of PUSH_OBJECT. + */ - /* - * 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. - */ + OBJ_AT_DEPTH(objc-1) = tmpPtr; + Tcl_IncrRefCount(tmpPtr); - TclNewObj(objPtr); - Tcl_IncrRefCount(objPtr); - iPtr->objResultPtr = objPtr; - NEXT_INST_F(1, 1, -1); - } else { - cleanup = 1; - goto processExceptionReturn; - } - } + pcAdjustment = 2; + goto doInvocation; +#else + /* + * INST_CALL_BUILTIN_FUNC1 and INST_CALL_FUNC1 were made obsolete by the + * changes to add a ::tcl::mathfunc namespace in 8.5. Optional support + * remains for existing bytecode precompiled files. + */ - case INST_EXPR_STK: { - Tcl_Obj *objPtr, *valuePtr; + case INST_CALL_BUILTIN_FUNC1: + Tcl_Panic("TclNRExecuteByteCode: obsolete INST_CALL_BUILTIN_FUNC1 found"); + case INST_CALL_FUNC1: + Tcl_Panic("TclNRExecuteByteCode: obsolete INST_CALL_FUNC1 found"); +#endif - objPtr = *tosPtr; - DECACHE_STACK_INFO(); - Tcl_ResetResult(interp); - result = Tcl_ExprObj(interp, objPtr, &valuePtr); - CACHE_STACK_INFO(); - if (result != TCL_OK) { - TRACE_WITH_OBJ(("\"%.30s\" => ERROR: ", O2S(objPtr)), - Tcl_GetObjResult(interp)); - goto checkForCatch; + 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) { + int i; + + if (traceInstructions) { + strncpy(cmdNameBuf, TclGetString(objv[0]), 20); + TRACE(("%u => call (implementation %s) ", objc, O2S(objPtr))); + } else { + fprintf(stdout, + "%d: (%u) invoking (using implementation %s) ", + iPtr->numLevels, (unsigned)(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); } - objResultPtr = valuePtr; - TRACE_WITH_OBJ(("\"%.30s\" => ", O2S(objPtr)), valuePtr); - NEXT_INST_F(1, 1, -1); /* already has right refct */ - } +#endif /*TCL_COMPILE_DEBUG*/ + { + Tcl_Obj *copyPtr = Tcl_NewListObj(objc - opnd + 1, NULL); + register List *listRepPtr = copyPtr->internalRep.twoPtrValue.ptr1; + Tcl_Obj **copyObjv = &listRepPtr->elements; + int i; + + listRepPtr->elemCount = objc - opnd + 1; + copyObjv[0] = objPtr; + memcpy(copyObjv+1, objv+opnd, sizeof(Tcl_Obj *) * (objc - opnd)); + for (i=1 ; i<objc-opnd+1 ; i++) { + Tcl_IncrRefCount(copyObjv[i]); + } + objPtr = copyPtr; + } + bcFramePtr->data.tebc.pc = (char *) pc; + iPtr->cmdFramePtr = bcFramePtr; + if (iPtr->flags & INTERP_DEBUG_FRAME) { + ArgumentBCEnter(interp, codePtr, TD, pc, objc, objv); + } + iPtr->ensembleRewrite.sourceObjs = objv; + iPtr->ensembleRewrite.numRemovedObjs = opnd; + iPtr->ensembleRewrite.numInsertedObjs = 1; + DECACHE_STACK_INFO(); + pc += 6; + TEBC_YIELD(); + + TclNRAddCallback(interp, TclClearRootEnsemble, NULL,NULL,NULL,NULL); + TclSkipTailcall(interp); + return TclNREvalObjEx(interp, objPtr, TCL_EVAL_INVOKE, NULL, INT_MIN); /* - * --------------------------------------------------------- + * ----------------------------------------------------------------- * 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 somme + * 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; - char *part1, *part2; - Var *varPtr, *arrayPtr; - Tcl_Obj *objPtr; case INST_LOAD_SCALAR1: + instLoadScalar1: opnd = TclGetUInt1AtPtr(pc+1); - varPtr = &(compiledLocals[opnd]); - part1 = varPtr->name; + varPtr = LOCAL(opnd); while (TclIsVarLink(varPtr)) { varPtr = varPtr->value.linkPtr; } @@ -1977,6 +3236,7 @@ TclExecuteByteCode( /* * No errors, no traces: just get the value. */ + objResultPtr = varPtr->value.objPtr; TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); NEXT_INST_F(2, 0, 1); @@ -1984,13 +3244,12 @@ TclExecuteByteCode( pcAdjustment = 2; cleanup = 0; arrayPtr = NULL; - part2 = NULL; + part1Ptr = part2Ptr = NULL; goto doCallPtrGetVar; case INST_LOAD_SCALAR4: opnd = TclGetUInt4AtPtr(pc+1); - varPtr = &(compiledLocals[opnd]); - part1 = varPtr->name; + varPtr = LOCAL(opnd); while (TclIsVarLink(varPtr)) { varPtr = varPtr->value.linkPtr; } @@ -1999,6 +3258,7 @@ TclExecuteByteCode( /* * No errors, no traces: just get the value. */ + objResultPtr = varPtr->value.objPtr; TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); NEXT_INST_F(5, 0, 1); @@ -2006,42 +3266,7 @@ TclExecuteByteCode( pcAdjustment = 5; cleanup = 0; arrayPtr = NULL; - part2 = NULL; - goto doCallPtrGetVar; - - case INST_LOAD_ARRAY_STK: - cleanup = 2; - part2 = Tcl_GetString(*tosPtr); /* element name */ - objPtr = *(tosPtr - 1); /* array name */ - TRACE(("\"%.30s(%.30s)\" => ", O2S(objPtr), part2)); - goto doLoadStk; - - case INST_LOAD_STK: - case INST_LOAD_SCALAR_STK: - cleanup = 1; - part2 = NULL; - objPtr = *tosPtr; /* variable name */ - TRACE(("\"%.30s\" => ", O2S(objPtr))); - - doLoadStk: - part1 = TclGetString(objPtr); - varPtr = TclObjLookupVar(interp, objPtr, part2, TCL_LEAVE_ERR_MSG, - "read", /*createPart1*/ 0, /*createPart2*/ 1, &arrayPtr); - if (varPtr == NULL) { - TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); - result = TCL_ERROR; - goto checkForCatch; - } - if (TclIsVarDirectReadable(varPtr) - && ((arrayPtr == NULL) || TclIsVarUntraced(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); - } - pcAdjustment = 1; + part1Ptr = part2Ptr = NULL; goto doCallPtrGetVar; case INST_LOAD_ARRAY4: @@ -2054,31 +3279,69 @@ TclExecuteByteCode( pcAdjustment = 2; doLoadArray: - part2 = TclGetString(*tosPtr); - arrayPtr = &(compiledLocals[opnd]); - part1 = arrayPtr->name; + part1Ptr = NULL; + part2Ptr = OBJ_AT_TOS; + arrayPtr = LOCAL(opnd); while (TclIsVarLink(arrayPtr)) { arrayPtr = arrayPtr->value.linkPtr; } - TRACE(("%u \"%.30s\" => ", opnd, part2)); - varPtr = TclLookupArrayElement(interp, part1, part2, - TCL_LEAVE_ERR_MSG, "read", 0, 1, arrayPtr); + TRACE(("%u \"%.30s\" => ", opnd, O2S(part2Ptr))); + if (TclIsVarArray(arrayPtr) && !ReadTraced(arrayPtr)) { + varPtr = VarHashFindVar(arrayPtr->value.tablePtr, part2Ptr); + if (varPtr && TclIsVarDirectReadable(varPtr)) { + /* + * No errors, no traces: just get the value. + */ + + objResultPtr = varPtr->value.objPtr; + TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); + NEXT_INST_F(pcAdjustment, 1, 1); + } + } + varPtr = TclLookupArrayElement(interp, part1Ptr, part2Ptr, + TCL_LEAVE_ERR_MSG, "read", 0, 1, arrayPtr, opnd); if (varPtr == NULL) { - TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); - result = TCL_ERROR; - goto checkForCatch; + TRACE_ERROR(interp); + goto gotError; + } + cleanup = 1; + goto doCallPtrGetVar; + + case INST_LOAD_ARRAY_STK: + cleanup = 2; + part2Ptr = OBJ_AT_TOS; /* element name */ + objPtr = OBJ_UNDER_TOS; /* array name */ + TRACE(("\"%.30s(%.30s)\" => ", O2S(objPtr), O2S(part2Ptr))); + goto doLoadStk; + + case INST_LOAD_STK: + case INST_LOAD_SCALAR_STK: + cleanup = 1; + part2Ptr = NULL; + objPtr = OBJ_AT_TOS; /* variable name */ + TRACE(("\"%.30s\" => ", O2S(objPtr))); + + doLoadStk: + part1Ptr = objPtr; + varPtr = TclObjLookupVarEx(interp, part1Ptr, part2Ptr, + TCL_LEAVE_ERR_MSG, "read", /*createPart1*/0, /*createPart2*/1, + &arrayPtr); + if (!varPtr) { + TRACE_ERROR(interp); + goto gotError; } - if (TclIsVarDirectReadable(varPtr) - && ((arrayPtr == NULL) || TclIsVarUntraced(arrayPtr))) { + + if (TclIsVarDirectReadable2(varPtr, arrayPtr)) { /* * No errors, no traces: just get the value. */ + objResultPtr = varPtr->value.objPtr; TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); - NEXT_INST_F(pcAdjustment, 1, 1); + NEXT_INST_V(1, cleanup, 1); } - cleanup = 1; - goto doCallPtrGetVar; + pcAdjustment = 1; + opnd = -1; doCallPtrGetVar: /* @@ -2087,110 +3350,179 @@ TclExecuteByteCode( */ DECACHE_STACK_INFO(); - objResultPtr = TclPtrGetVar(interp, varPtr, arrayPtr, part1, part2, - TCL_LEAVE_ERR_MSG); + objResultPtr = TclPtrGetVar(interp, varPtr, arrayPtr, + part1Ptr, part2Ptr, TCL_LEAVE_ERR_MSG, opnd); CACHE_STACK_INFO(); - if (objResultPtr == NULL) { - TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); - result = TCL_ERROR; - goto checkForCatch; + if (!objResultPtr) { + TRACE_ERROR(interp); + goto gotError; } TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); NEXT_INST_V(pcAdjustment, cleanup, 1); - } /* * End of INST_LOAD instructions. - * --------------------------------------------------------- - */ - - /* - * --------------------------------------------------------- + * ----------------------------------------------------------------- * Start of INST_STORE and related instructions. * - * WARNING: more 'goto' here than your doctor recommended! The different + * WARNING: more 'goto' here than your doctor recommended! The different * instructions set the value of some variables and then jump to somme * common execution code. */ { - int opnd, pcAdjustment, storeFlags; - char *part1, *part2; - Var *varPtr, *arrayPtr; - Tcl_Obj *objPtr, *valuePtr; + int storeFlags; + + case INST_STORE_ARRAY4: + opnd = TclGetUInt4AtPtr(pc+1); + pcAdjustment = 5; + goto doStoreArrayDirect; + + case INST_STORE_ARRAY1: + opnd = TclGetUInt1AtPtr(pc+1); + pcAdjustment = 2; + + doStoreArrayDirect: + valuePtr = OBJ_AT_TOS; + part2Ptr = OBJ_UNDER_TOS; + arrayPtr = LOCAL(opnd); + TRACE(("%u \"%.30s\" <- \"%.30s\" => ", opnd, O2S(part2Ptr), + O2S(valuePtr))); + while (TclIsVarLink(arrayPtr)) { + arrayPtr = arrayPtr->value.linkPtr; + } + if (TclIsVarArray(arrayPtr) && !WriteTraced(arrayPtr)) { + varPtr = VarHashFindVar(arrayPtr->value.tablePtr, part2Ptr); + if (varPtr && TclIsVarDirectWritable(varPtr)) { + tosPtr--; + Tcl_DecrRefCount(OBJ_AT_TOS); + OBJ_AT_TOS = valuePtr; + goto doStoreVarDirect; + } + } + cleanup = 2; + storeFlags = TCL_LEAVE_ERR_MSG; + part1Ptr = NULL; + goto doStoreArrayDirectFailed; + + case INST_STORE_SCALAR4: + opnd = TclGetUInt4AtPtr(pc+1); + pcAdjustment = 5; + goto doStoreScalarDirect; + + case INST_STORE_SCALAR1: + opnd = TclGetUInt1AtPtr(pc+1); + pcAdjustment = 2; + + doStoreScalarDirect: + valuePtr = OBJ_AT_TOS; + varPtr = LOCAL(opnd); + TRACE(("%u <- \"%.30s\" => ", opnd, O2S(valuePtr))); + while (TclIsVarLink(varPtr)) { + varPtr = varPtr->value.linkPtr; + } + 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. + */ + + doStoreVarDirect: + valuePtr = varPtr->value.objPtr; + if (valuePtr != NULL) { + TclDecrRefCount(valuePtr); + } + objResultPtr = OBJ_AT_TOS; + varPtr->value.objPtr = objResultPtr; +#ifndef TCL_COMPILE_DEBUG + if (*(pc+pcAdjustment) == INST_POP) { + tosPtr--; + NEXT_INST_F((pcAdjustment+1), 0, 0); + } +#else + TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); +#endif + Tcl_IncrRefCount(objResultPtr); + NEXT_INST_F(pcAdjustment, 0, 0); case INST_LAPPEND_STK: - valuePtr = *tosPtr; /* value to append */ - part2 = NULL; + valuePtr = OBJ_AT_TOS; /* value to append */ + part2Ptr = NULL; storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE - | TCL_LIST_ELEMENT | TCL_TRACE_READS); + | TCL_LIST_ELEMENT); goto doStoreStk; case INST_LAPPEND_ARRAY_STK: - valuePtr = *tosPtr; /* value to append */ - part2 = TclGetString(*(tosPtr - 1)); + valuePtr = OBJ_AT_TOS; /* value to append */ + part2Ptr = OBJ_UNDER_TOS; storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE - | TCL_LIST_ELEMENT | TCL_TRACE_READS); + | TCL_LIST_ELEMENT); goto doStoreStk; case INST_APPEND_STK: - valuePtr = *tosPtr; /* value to append */ - part2 = NULL; + valuePtr = OBJ_AT_TOS; /* value to append */ + part2Ptr = NULL; storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE); goto doStoreStk; case INST_APPEND_ARRAY_STK: - valuePtr = *tosPtr; /* value to append */ - part2 = TclGetString(*(tosPtr - 1)); + valuePtr = OBJ_AT_TOS; /* value to append */ + part2Ptr = OBJ_UNDER_TOS; storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE); goto doStoreStk; case INST_STORE_ARRAY_STK: - valuePtr = *tosPtr; - part2 = TclGetString(*(tosPtr - 1)); + valuePtr = OBJ_AT_TOS; + part2Ptr = OBJ_UNDER_TOS; storeFlags = TCL_LEAVE_ERR_MSG; goto doStoreStk; case INST_STORE_STK: case INST_STORE_SCALAR_STK: - valuePtr = *tosPtr; - part2 = NULL; + valuePtr = OBJ_AT_TOS; + part2Ptr = NULL; storeFlags = TCL_LEAVE_ERR_MSG; doStoreStk: - objPtr = *(tosPtr - 1 - (part2 != NULL)); /* variable name */ - part1 = TclGetString(objPtr); + objPtr = OBJ_AT_DEPTH(1 + (part2Ptr != NULL)); /* variable name */ + part1Ptr = objPtr; #ifdef TCL_COMPILE_DEBUG - if (part2 == NULL) { - TRACE(("\"%.30s\" <- \"%.30s\" =>", part1, O2S(valuePtr))); + if (part2Ptr == NULL) { + TRACE(("\"%.30s\" <- \"%.30s\" =>", O2S(part1Ptr),O2S(valuePtr))); } else { TRACE(("\"%.30s(%.30s)\" <- \"%.30s\" => ", - part1, part2, O2S(valuePtr))); + O2S(part1Ptr), O2S(part2Ptr), O2S(valuePtr))); } #endif - varPtr = TclObjLookupVar(interp, objPtr, part2, TCL_LEAVE_ERR_MSG, + varPtr = TclObjLookupVarEx(interp, objPtr,part2Ptr, TCL_LEAVE_ERR_MSG, "set", /*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr); - if (varPtr == NULL) { - TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); - result = TCL_ERROR; - goto checkForCatch; + if (!varPtr) { + TRACE_ERROR(interp); + goto gotError; } - cleanup = ((part2 == NULL)? 2 : 3); + cleanup = ((part2Ptr == NULL)? 2 : 3); pcAdjustment = 1; + opnd = -1; goto doCallPtrSetVar; case INST_LAPPEND_ARRAY4: opnd = TclGetUInt4AtPtr(pc+1); pcAdjustment = 5; storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE - | TCL_LIST_ELEMENT | TCL_TRACE_READS); + | TCL_LIST_ELEMENT); goto doStoreArray; case INST_LAPPEND_ARRAY1: opnd = TclGetUInt1AtPtr(pc+1); pcAdjustment = 2; storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE - | TCL_LIST_ELEMENT | TCL_TRACE_READS); + | TCL_LIST_ELEMENT); goto doStoreArray; case INST_APPEND_ARRAY4: @@ -2205,48 +3537,39 @@ TclExecuteByteCode( storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE); goto doStoreArray; - case INST_STORE_ARRAY4: - opnd = TclGetUInt4AtPtr(pc+1); - pcAdjustment = 5; - storeFlags = TCL_LEAVE_ERR_MSG; - goto doStoreArray; - - case INST_STORE_ARRAY1: - opnd = TclGetUInt1AtPtr(pc+1); - pcAdjustment = 2; - storeFlags = TCL_LEAVE_ERR_MSG; - doStoreArray: - valuePtr = *tosPtr; - part2 = TclGetString(*(tosPtr - 1)); - arrayPtr = &(compiledLocals[opnd]); - part1 = arrayPtr->name; - TRACE(("%u \"%.30s\" <- \"%.30s\" => ", opnd, part2, O2S(valuePtr))); + valuePtr = OBJ_AT_TOS; + part2Ptr = OBJ_UNDER_TOS; + arrayPtr = LOCAL(opnd); + TRACE(("%u \"%.30s\" <- \"%.30s\" => ", opnd, O2S(part2Ptr), + O2S(valuePtr))); while (TclIsVarLink(arrayPtr)) { arrayPtr = arrayPtr->value.linkPtr; } - varPtr = TclLookupArrayElement(interp, part1, part2, - TCL_LEAVE_ERR_MSG, "set", 1, 1, arrayPtr); - if (varPtr == NULL) { - TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); - result = TCL_ERROR; - goto checkForCatch; - } cleanup = 2; + part1Ptr = NULL; + + doStoreArrayDirectFailed: + varPtr = TclLookupArrayElement(interp, part1Ptr, part2Ptr, + TCL_LEAVE_ERR_MSG, "set", 1, 1, arrayPtr, opnd); + if (!varPtr) { + TRACE_ERROR(interp); + goto gotError; + } goto doCallPtrSetVar; case INST_LAPPEND_SCALAR4: opnd = TclGetUInt4AtPtr(pc+1); pcAdjustment = 5; storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE - | TCL_LIST_ELEMENT | TCL_TRACE_READS); + | TCL_LIST_ELEMENT); goto doStoreScalar; case INST_LAPPEND_SCALAR1: opnd = TclGetUInt1AtPtr(pc+1); pcAdjustment = 2; storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE - | TCL_LIST_ELEMENT | TCL_TRACE_READS); + | TCL_LIST_ELEMENT); goto doStoreScalar; case INST_APPEND_SCALAR4: @@ -2261,69 +3584,25 @@ TclExecuteByteCode( storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE); goto doStoreScalar; - case INST_STORE_SCALAR4: - opnd = TclGetUInt4AtPtr(pc+1); - pcAdjustment = 5; - storeFlags = TCL_LEAVE_ERR_MSG; - goto doStoreScalar; - - case INST_STORE_SCALAR1: - opnd = TclGetUInt1AtPtr(pc+1); - pcAdjustment = 2; - storeFlags = TCL_LEAVE_ERR_MSG; - doStoreScalar: - valuePtr = *tosPtr; - varPtr = &(compiledLocals[opnd]); - part1 = varPtr->name; + valuePtr = OBJ_AT_TOS; + varPtr = LOCAL(opnd); TRACE(("%u <- \"%.30s\" => ", opnd, O2S(valuePtr))); while (TclIsVarLink(varPtr)) { varPtr = varPtr->value.linkPtr; } cleanup = 1; arrayPtr = NULL; - part2 = NULL; + part1Ptr = part2Ptr = NULL; doCallPtrSetVar: - if ((storeFlags == TCL_LEAVE_ERR_MSG) - && TclIsVarDirectWritable(varPtr) - && ((arrayPtr == NULL) || TclIsVarUntraced(arrayPtr))) { - /* - * No traces, no errors, plain 'set': we can safely inline. The - * value *will* be set to what's requested, so that the stack top - * remains pointing to the same Tcl_Obj. - */ - - valuePtr = varPtr->value.objPtr; - objResultPtr = *tosPtr; - if (valuePtr != objResultPtr) { - if (valuePtr != NULL) { - TclDecrRefCount(valuePtr); - } else { - TclSetVarScalar(varPtr); - TclClearVarUndefined(varPtr); - } - varPtr->value.objPtr = objResultPtr; - Tcl_IncrRefCount(objResultPtr); - } -#ifndef TCL_COMPILE_DEBUG - if (*(pc+pcAdjustment) == INST_POP) { - NEXT_INST_V((pcAdjustment+1), cleanup, 0); - } -#else - TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); -#endif - NEXT_INST_V(pcAdjustment, cleanup, 1); - } else { - DECACHE_STACK_INFO(); - objResultPtr = TclPtrSetVar(interp, varPtr, arrayPtr, - part1, part2, valuePtr, storeFlags); - CACHE_STACK_INFO(); - if (objResultPtr == NULL) { - TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); - result = TCL_ERROR; - goto checkForCatch; - } + DECACHE_STACK_INFO(); + objResultPtr = TclPtrSetVar(interp, varPtr, arrayPtr, + part1Ptr, part2Ptr, valuePtr, storeFlags, opnd); + CACHE_STACK_INFO(); + if (!objResultPtr) { + TRACE_ERROR(interp); + goto gotError; } #ifndef TCL_COMPILE_DEBUG if (*(pc+pcAdjustment) == INST_POP) { @@ -2336,29 +3615,22 @@ TclExecuteByteCode( /* * End of INST_STORE and related instructions. - * --------------------------------------------------------- - */ - - /* - * --------------------------------------------------------- + * ----------------------------------------------------------------- * Start of INST_INCR instructions. * - * WARNING: more 'goto' here than your doctor recommended! The different + * WARNING: more 'goto' here than your doctor recommended! The different * instructions set the value of some variables and then jump to somme * common execution code. */ -/*TODO: Consider more untangling here; merge with LOAD and STORE ? */ +/*TODO: Consider more untangling here; merge with LOAD and STORE ? */ { - Tcl_Obj *objPtr, *incrPtr; - int opnd, pcAdjustment; -#ifndef NO_WIDE_TYPE + Tcl_Obj *incrPtr; +#ifndef TCL_WIDE_INT_IS_LONG Tcl_WideInt w; #endif - long i; - char *part1, *part2; - Var *varPtr, *arrayPtr; + long increment; case INST_INCR_SCALAR1: case INST_INCR_ARRAY1: @@ -2366,8 +3638,7 @@ TclExecuteByteCode( case INST_INCR_SCALAR_STK: case INST_INCR_STK: opnd = TclGetUInt1AtPtr(pc+1); - incrPtr = *tosPtr; - tosPtr--; + incrPtr = POP_OBJECT(); switch (*pc) { case INST_INCR_SCALAR1: pcAdjustment = 2; @@ -2383,91 +3654,94 @@ TclExecuteByteCode( case INST_INCR_ARRAY_STK_IMM: case INST_INCR_SCALAR_STK_IMM: case INST_INCR_STK_IMM: - i = TclGetInt1AtPtr(pc+1); - incrPtr = Tcl_NewIntObj(i); + increment = TclGetInt1AtPtr(pc+1); + incrPtr = Tcl_NewIntObj(increment); Tcl_IncrRefCount(incrPtr); pcAdjustment = 2; doIncrStk: if ((*pc == INST_INCR_ARRAY_STK_IMM) || (*pc == INST_INCR_ARRAY_STK)) { - part2 = TclGetString(*tosPtr); - objPtr = *(tosPtr - 1); + part2Ptr = OBJ_AT_TOS; + objPtr = OBJ_UNDER_TOS; TRACE(("\"%.30s(%.30s)\" (by %ld) => ", - O2S(objPtr), part2, i)); + O2S(objPtr), O2S(part2Ptr), increment)); } else { - part2 = NULL; - objPtr = *tosPtr; - TRACE(("\"%.30s\" (by %ld) => ", O2S(objPtr), i)); - } - part1 = TclGetString(objPtr); - - varPtr = TclObjLookupVar(interp, objPtr, part2, - TCL_LEAVE_ERR_MSG, "read", 0, 1, &arrayPtr); - if (varPtr == NULL) { - Tcl_AddObjErrorInfo(interp, - "\n (reading value of variable to increment)", -1); - TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); - result = TCL_ERROR; + part2Ptr = NULL; + objPtr = OBJ_AT_TOS; + TRACE(("\"%.30s\" (by %ld) => ", O2S(objPtr), increment)); + } + 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); Tcl_DecrRefCount(incrPtr); - goto checkForCatch; + goto gotError; } - cleanup = ((part2 == NULL)? 1 : 2); + cleanup = ((part2Ptr == NULL)? 1 : 2); goto doIncrVar; case INST_INCR_ARRAY1_IMM: opnd = TclGetUInt1AtPtr(pc+1); - i = TclGetInt1AtPtr(pc+2); - incrPtr = Tcl_NewIntObj(i); + increment = TclGetInt1AtPtr(pc+2); + incrPtr = Tcl_NewIntObj(increment); Tcl_IncrRefCount(incrPtr); pcAdjustment = 3; doIncrArray: - part2 = TclGetString(*tosPtr); - arrayPtr = &(compiledLocals[opnd]); - part1 = arrayPtr->name; + part1Ptr = NULL; + part2Ptr = OBJ_AT_TOS; + arrayPtr = LOCAL(opnd); + cleanup = 1; while (TclIsVarLink(arrayPtr)) { arrayPtr = arrayPtr->value.linkPtr; } - TRACE(("%u \"%.30s\" (by %ld) => ", opnd, part2, i)); - varPtr = TclLookupArrayElement(interp, part1, part2, - TCL_LEAVE_ERR_MSG, "read", 0, 1, arrayPtr); - if (varPtr == NULL) { - TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); - result = TCL_ERROR; + TRACE(("%u \"%.30s\" (by %ld) => ", opnd, O2S(part2Ptr), increment)); + varPtr = TclLookupArrayElement(interp, part1Ptr, part2Ptr, + TCL_LEAVE_ERR_MSG, "read", 1, 1, arrayPtr, opnd); + if (!varPtr) { + TRACE_ERROR(interp); Tcl_DecrRefCount(incrPtr); - goto checkForCatch; + goto gotError; } - cleanup = 1; goto doIncrVar; case INST_INCR_SCALAR1_IMM: opnd = TclGetUInt1AtPtr(pc+1); - i = TclGetInt1AtPtr(pc+2); + increment = TclGetInt1AtPtr(pc+2); pcAdjustment = 3; cleanup = 0; - varPtr = &(compiledLocals[opnd]); + varPtr = LOCAL(opnd); while (TclIsVarLink(varPtr)) { varPtr = varPtr->value.linkPtr; } - if (TclIsVarDirectReadable(varPtr)) { + if (TclIsVarDirectModifyable(varPtr)) { ClientData ptr; int type; objPtr = varPtr->value.objPtr; if (GetNumberFromObj(NULL, objPtr, &ptr, &type) == TCL_OK) { if (type == TCL_NUMBER_LONG) { - long augend = *((CONST long *)ptr); - long sum = augend + i; - /* Test for overflow */ - /* TODO: faster checking with known limits on i ? */ - if ((augend >= 0 || i >= 0 || sum < 0) - && (sum >= 0 || i < 0 || augend < 0)) { - - TRACE(("%u %ld => ", opnd, i)); + long augend = *((const long *)ptr); + long sum = augend + increment; + + /* + * Overflow when (augend and sum have different sign) and + * (augend and increment have the same sign). This is + * encapsulated in the Overflowing macro. + */ + + if (!Overflowing(augend, increment, sum)) { + TRACE(("%u %ld => ", opnd, increment)); if (Tcl_IsShared(objPtr)) { - objPtr->refCount--; /* we know it's shared */ + objPtr->refCount--; /* We know it's shared. */ TclNewLongObj(objResultPtr, sum); Tcl_IncrRefCount(objResultPtr); varPtr->value.objPtr = objResultPtr; @@ -2477,46 +3751,55 @@ TclExecuteByteCode( } goto doneIncr; } -#ifndef NO_WIDE_TYPE - { - w = (Tcl_WideInt)augend; +#ifndef TCL_WIDE_INT_IS_LONG + w = (Tcl_WideInt)augend; + + TRACE(("%u %ld => ", opnd, increment)); + if (Tcl_IsShared(objPtr)) { + objPtr->refCount--; /* We know it's shared. */ + objResultPtr = Tcl_NewWideIntObj(w+increment); + Tcl_IncrRefCount(objResultPtr); + varPtr->value.objPtr = objResultPtr; + } else { + objResultPtr = objPtr; - 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; - /* 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; + /* + * We know the sum value is outside the long range; + * use macro form that doesn't range test again. + */ + + TclSetWideIntObj(objPtr, w+increment); } + goto doneIncr; #endif } /* end if (type == TCL_NUMBER_LONG) */ -#ifndef NO_WIDE_TYPE +#ifndef TCL_WIDE_INT_IS_LONG if (type == TCL_NUMBER_WIDE) { Tcl_WideInt sum; - w = *((CONST Tcl_WideInt *)ptr); - sum = w + i; - /* Check for overflow */ - if ((w >= 0 || i >= 0 || sum < 0) - && (w < 0 || i < 0 || sum >= 0)) { - TRACE(("%u %ld => ", opnd, i)); + w = *((const Tcl_WideInt *) ptr); + sum = w + increment; + + /* + * Check for overflow. + */ + + if (!Overflowing(w, increment, sum)) { + TRACE(("%u %ld => ", opnd, increment)); if (Tcl_IsShared(objPtr)) { - objPtr->refCount--; /* we know it's shared */ + 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. */ + + /* + * 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; @@ -2525,65 +3808,66 @@ TclExecuteByteCode( #endif } if (Tcl_IsShared(objPtr)) { - objPtr->refCount--; /* we know it's shared */ + objPtr->refCount--; /* We know it's shared */ objResultPtr = Tcl_DuplicateObj(objPtr); Tcl_IncrRefCount(objResultPtr); varPtr->value.objPtr = objResultPtr; } else { objResultPtr = objPtr; } - TclNewLongObj(incrPtr, i); - result = TclIncrObj(interp, objResultPtr, incrPtr); - Tcl_DecrRefCount(incrPtr); - if (result != TCL_OK) { - TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); - goto checkForCatch; + TclNewLongObj(incrPtr, increment); + if (TclIncrObj(interp, objResultPtr, incrPtr) != TCL_OK) { + Tcl_DecrRefCount(incrPtr); + TRACE_ERROR(interp); + goto gotError; } + Tcl_DecrRefCount(incrPtr); goto doneIncr; } - /* All other cases, flow through to generic handling */ - TclNewLongObj(incrPtr, i); + + /* + * All other cases, flow through to generic handling. + */ + + TclNewLongObj(incrPtr, increment); Tcl_IncrRefCount(incrPtr); doIncrScalar: - varPtr = &(compiledLocals[opnd]); - part1 = varPtr->name; + varPtr = LOCAL(opnd); while (TclIsVarLink(varPtr)) { varPtr = varPtr->value.linkPtr; } arrayPtr = NULL; - part2 = NULL; + part1Ptr = part2Ptr = NULL; cleanup = 0; - TRACE(("%u %ld => ", opnd, i)); + TRACE(("%u %s => ", opnd, Tcl_GetString(incrPtr))); doIncrVar: - if (TclIsVarDirectReadable(varPtr) - && ((arrayPtr == NULL) || TclIsVarUntraced(arrayPtr))) { + if (TclIsVarDirectModifyable2(varPtr, arrayPtr)) { objPtr = varPtr->value.objPtr; if (Tcl_IsShared(objPtr)) { - objPtr->refCount--; /* we know it's shared */ + objPtr->refCount--; /* We know it's shared */ objResultPtr = Tcl_DuplicateObj(objPtr); Tcl_IncrRefCount(objResultPtr); varPtr->value.objPtr = objResultPtr; } else { objResultPtr = objPtr; } - result = TclIncrObj(interp, objResultPtr, incrPtr); - Tcl_DecrRefCount(incrPtr); - if (result != TCL_OK) { - TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); - goto checkForCatch; + if (TclIncrObj(interp, objResultPtr, incrPtr) != TCL_OK) { + Tcl_DecrRefCount(incrPtr); + TRACE_ERROR(interp); + goto gotError; } + Tcl_DecrRefCount(incrPtr); } else { DECACHE_STACK_INFO(); objResultPtr = TclPtrIncrObjVar(interp, varPtr, arrayPtr, - part1, part2, incrPtr, TCL_LEAVE_ERR_MSG); + part1Ptr, part2Ptr, incrPtr, TCL_LEAVE_ERR_MSG, opnd); CACHE_STACK_INFO(); Tcl_DecrRefCount(incrPtr); if (objResultPtr == NULL) { - TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); - result = TCL_ERROR; - goto checkForCatch; + TRACE_ERROR(interp); + goto gotError; } } doneIncr: @@ -2598,37 +3882,503 @@ TclExecuteByteCode( /* * End of INST_INCR instructions. - * --------------------------------------------------------- + * ----------------------------------------------------------------- + * Start of INST_EXIST instructions. */ - case INST_JUMP1: { - int opnd; + case INST_EXIST_SCALAR: + cleanup = 0; + pcAdjustment = 5; + opnd = TclGetUInt4AtPtr(pc+1); + varPtr = LOCAL(opnd); + while (TclIsVarLink(varPtr)) { + varPtr = varPtr->value.linkPtr; + } + TRACE(("%u => ", opnd)); + if (ReadTraced(varPtr)) { + DECACHE_STACK_INFO(); + TclObjCallVarTraces(iPtr, NULL, varPtr, NULL, NULL, + TCL_TRACE_READS, 0, opnd); + CACHE_STACK_INFO(); + if (TclIsVarUndefined(varPtr)) { + TclCleanupVar(varPtr, NULL); + varPtr = NULL; + } + } + goto afterExistsPeephole; + + case INST_EXIST_ARRAY: + cleanup = 1; + pcAdjustment = 5; + opnd = TclGetUInt4AtPtr(pc+1); + part2Ptr = OBJ_AT_TOS; + arrayPtr = LOCAL(opnd); + while (TclIsVarLink(arrayPtr)) { + arrayPtr = arrayPtr->value.linkPtr; + } + TRACE(("%u \"%.30s\" => ", opnd, O2S(part2Ptr))); + if (TclIsVarArray(arrayPtr) && !ReadTraced(arrayPtr)) { + varPtr = VarHashFindVar(arrayPtr->value.tablePtr, part2Ptr); + if (!varPtr || !ReadTraced(varPtr)) { + goto afterExistsPeephole; + } + } + varPtr = TclLookupArrayElement(interp, NULL, part2Ptr, 0, "access", + 0, 1, arrayPtr, opnd); + if (varPtr) { + if (ReadTraced(varPtr) || (arrayPtr && ReadTraced(arrayPtr))) { + DECACHE_STACK_INFO(); + TclObjCallVarTraces(iPtr, arrayPtr, varPtr, NULL, part2Ptr, + TCL_TRACE_READS, 0, opnd); + CACHE_STACK_INFO(); + } + if (TclIsVarUndefined(varPtr)) { + TclCleanupVar(varPtr, arrayPtr); + varPtr = NULL; + } + } + goto afterExistsPeephole; + + 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))); + goto doExistStk; + + case INST_EXIST_STK: + cleanup = 1; + pcAdjustment = 1; + part2Ptr = NULL; + part1Ptr = OBJ_AT_TOS; /* variable name */ + TRACE(("\"%.30s\" => ", O2S(part1Ptr))); + + doExistStk: + varPtr = TclObjLookupVarEx(interp, part1Ptr, part2Ptr, 0, "access", + /*createPart1*/0, /*createPart2*/1, &arrayPtr); + if (varPtr) { + if (ReadTraced(varPtr) || (arrayPtr && ReadTraced(arrayPtr))) { + DECACHE_STACK_INFO(); + TclObjCallVarTraces(iPtr, arrayPtr, varPtr, part1Ptr,part2Ptr, + TCL_TRACE_READS, 0, -1); + CACHE_STACK_INFO(); + } + if (TclIsVarUndefined(varPtr)) { + TclCleanupVar(varPtr, arrayPtr); + varPtr = NULL; + } + } + + /* + * 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); + } + + /* + * 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. + */ + 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); + } + + slowUnsetScalar: + DECACHE_STACK_INFO(); + if (TclPtrUnsetVar(interp, varPtr, NULL, NULL, NULL, flags, + opnd) != TCL_OK && flags) { + goto errorInUnset; + } + CACHE_STACK_INFO(); + NEXT_INST_F(6, 0, 0); + + case INST_UNSET_ARRAY: + flags = TclGetUInt1AtPtr(pc+1) ? TCL_LEAVE_ERR_MSG : 0; + opnd = TclGetUInt4AtPtr(pc+2); + part2Ptr = OBJ_AT_TOS; + arrayPtr = LOCAL(opnd); + while (TclIsVarLink(arrayPtr)) { + arrayPtr = arrayPtr->value.linkPtr; + } + TRACE(("%s %u \"%.30s\" => ", + (flags ? "normal" : "noerr"), opnd, O2S(part2Ptr))); + if (TclIsVarArray(arrayPtr) && !UnsetTraced(arrayPtr)) { + varPtr = VarHashFindVar(arrayPtr->value.tablePtr, part2Ptr); + if (varPtr && TclIsVarDirectUnsettable(varPtr)) { + /* + * No nasty traces and element exists, so we can proceed to + * unset it. Might still not exist though... + */ + + if (!TclIsVarUndefined(varPtr)) { + TclDecrRefCount(varPtr->value.objPtr); + } else if (flags & TCL_LEAVE_ERR_MSG) { + goto slowUnsetArray; + } + varPtr->value.objPtr = NULL; + 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); + } + } + slowUnsetArray: + DECACHE_STACK_INFO(); + varPtr = TclLookupArrayElement(interp, NULL, part2Ptr, flags, "unset", + 0, 0, arrayPtr, opnd); + if (!varPtr) { + if (flags & TCL_LEAVE_ERR_MSG) { + goto errorInUnset; + } + } else if (TclPtrUnsetVar(interp, varPtr, arrayPtr, NULL, part2Ptr, + flags, opnd) != TCL_OK && (flags & TCL_LEAVE_ERR_MSG)) { + goto errorInUnset; + } + CACHE_STACK_INFO(); + NEXT_INST_F(6, 1, 0); + + case INST_UNSET_ARRAY_STK: + flags = TclGetUInt1AtPtr(pc+1) ? TCL_LEAVE_ERR_MSG : 0; + cleanup = 2; + part2Ptr = OBJ_AT_TOS; /* element name */ + part1Ptr = OBJ_UNDER_TOS; /* array name */ + TRACE(("%s \"%.30s(%.30s)\" => ", (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_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(); + TclPtrUnsetVar(interp, varPtr, NULL, NULL, NULL, 0, opnd); + CACHE_STACK_INFO(); + } + NEXT_INST_F(5, 0, 0); + } + + /* + * End of INST_UNSET instructions. + * ----------------------------------------------------------------- + * Start of INST_ARRAY instructions. + */ + + 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: + if (varPtr && (varPtr->flags & VAR_TRACED_ARRAY) + && (TclIsVarArray(varPtr) || TclIsVarUndefined(varPtr))) { + DECACHE_STACK_INFO(); + result = TclObjCallVarTraces(iPtr, arrayPtr, varPtr, part1Ptr, + NULL, (TCL_LEAVE_ERR_MSG|TCL_NAMESPACE_ONLY| + TCL_GLOBAL_ONLY|TCL_TRACE_ARRAY), 1, 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); + + 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)) { + /* + * Either an array element, or a scalar: lose! + */ + + TclObjVarErrMsg(interp, part1Ptr, NULL, "array set", + "variable isn't array", opnd); + DECACHE_STACK_INFO(); + Tcl_SetErrorCode(interp, "TCL", "WRITE", "ARRAY", NULL); + CACHE_STACK_INFO(); + TRACE_ERROR(interp); + goto gotError; + } + TclSetVarArray(varPtr); + varPtr->value.tablePtr = ckalloc(sizeof(TclVarHashTable)); + TclInitVarHashTable(varPtr->value.tablePtr, + TclGetVarNsPtr(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), "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; + } + + /* + * Do the [variable] magic. + */ + + TclSetVarNamespaceVar(otherPtr); + + doLinkVars: + + /* + * If we are here, the local variable has already been created: do the + * little work of TclPtrMakeUpvar that remains to be done right here + * if there are no errors; otherwise, let it handle the case. + */ + + opnd = TclGetInt4AtPtr(pc+1); + varPtr = LOCAL(opnd); + if ((varPtr != otherPtr) && !TclIsVarTraced(varPtr) + && (TclIsVarUndefined(varPtr) || TclIsVarLink(varPtr))) { + if (!TclIsVarUndefined(varPtr)) { + /* + * Then it is a defined link. + */ + + Var *linkPtr = varPtr->value.linkPtr; + + if (linkPtr == otherPtr) { + TRACE_APPEND(("already linked\n")); + NEXT_INST_F(5, 1, 0); + } + if (TclIsVarInHash(linkPtr)) { + VarHashRefCount(linkPtr)--; + if (TclIsVarUndefined(linkPtr)) { + TclCleanupVar(linkPtr, NULL); + } + } + } + TclSetVarLink(varPtr); + varPtr->value.linkPtr = otherPtr; + if (TclIsVarInHash(otherPtr)) { + VarHashRefCount(otherPtr)++; + } + } else if (TclPtrObjMakeUpvar(interp, otherPtr, NULL, 0, + opnd) != TCL_OK) { + TRACE_ERROR(interp); + goto gotError; + } + + /* + * Do not pop the namespace or frame index, it may be needed for other + * variables - and [variable] did not push it at all. + */ + + TRACE_APPEND(("link made\n")); + NEXT_INST_F(5, 1, 0); + } + + /* + * End of variable linking instructions. + * ----------------------------------------------------------------- + */ + + case INST_JUMP1: opnd = TclGetInt1AtPtr(pc+1); TRACE(("%d => new pc %u\n", opnd, - (unsigned int)(pc + opnd - codePtr->codeStart))); + (unsigned)(pc + opnd - codePtr->codeStart))); NEXT_INST_F(opnd, 0, 0); - } - - case INST_JUMP4: { - int opnd; + case INST_JUMP4: opnd = TclGetInt4AtPtr(pc+1); TRACE(("%d => new pc %u\n", opnd, - (unsigned int)(pc + opnd - codePtr->codeStart))); + (unsigned)(pc + opnd - codePtr->codeStart))); NEXT_INST_F(opnd, 0, 0); - } { - int jmpOffset[2]; - int b; - Tcl_Obj *valuePtr; + int jmpOffset[2], b; -/* TODO: consider rewrite so we don't compute the offset we're - * not going to take. */ + /* 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: @@ -2646,32 +4396,31 @@ TclExecuteByteCode( jmpOffset[1] = TclGetInt1AtPtr(pc+1); doCondJump: - valuePtr = *tosPtr; + 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 eePtr->constants */ - 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; + /* TODO - consider optimization search for constants */ + if (TclGetBooleanFromObj(interp, valuePtr, &b) != TCL_OK) { + TRACE_ERROR(interp); + goto gotError; } #ifdef TCL_COMPILE_DEBUG if (b) { if ((*pc == INST_JUMP_TRUE1) || (*pc == INST_JUMP_TRUE4)) { - TRACE(("%d => %.20s true, new pc %u\n", jmpOffset[1], O2S(valuePtr), - (unsigned int)(pc+jmpOffset[1] - codePtr->codeStart))); + TRACE_APPEND(("%.20s true, new pc %u\n", O2S(valuePtr), + (unsigned)(pc + jmpOffset[1] - codePtr->codeStart))); } else { - TRACE(("%d => %.20s true\n", jmpOffset[0], O2S(valuePtr))); + TRACE_APPEND(("%.20s true\n", O2S(valuePtr))); } } else { if ((*pc == INST_JUMP_TRUE1) || (*pc == INST_JUMP_TRUE4)) { - TRACE(("%d => %.20s false\n", jmpOffset[0], O2S(valuePtr))); + TRACE_APPEND(("%.20s false\n", O2S(valuePtr))); } else { - TRACE(("%d => %.20s false, new pc %u\n", jmpOffset[0], O2S(valuePtr), - (unsigned int)(pc + jmpOffset[1] - codePtr->codeStart))); + TRACE_APPEND(("%.20s false, new pc %u\n", O2S(valuePtr), + (unsigned)(pc + jmpOffset[0] - codePtr->codeStart))); } } #endif @@ -2681,7 +4430,6 @@ TclExecuteByteCode( case INST_JUMP_TABLE: { Tcl_HashEntry *hPtr; JumptableInfo *jtPtr; - int opnd; /* * Jump to location looked up in a hashtable; fall through to next @@ -2690,13 +4438,13 @@ TclExecuteByteCode( opnd = TclGetInt4AtPtr(pc+1); jtPtr = (JumptableInfo *) codePtr->auxDataArrayPtr[opnd].clientData; - TRACE(("%d => %.20s ", opnd, O2S(*tosPtr))); - hPtr = Tcl_FindHashEntry(&jtPtr->hashTable, Tcl_GetString(*tosPtr)); + TRACE(("%d \"%.20s\" => ", opnd, O2S(OBJ_AT_TOS))); + hPtr = Tcl_FindHashEntry(&jtPtr->hashTable, TclGetString(OBJ_AT_TOS)); if (hPtr != NULL) { - int jumpOffset = (int) Tcl_GetHashValue(hPtr); + int jumpOffset = PTR2INT(Tcl_GetHashValue(hPtr)); TRACE_APPEND(("found in table, new pc %u\n", - (unsigned int)(pc - codePtr->codeStart + jumpOffset))); + (unsigned)(pc - codePtr->codeStart + jumpOffset))); NEXT_INST_F(jumpOffset, 1, 0); } else { TRACE_APPEND(("not found in table\n")); @@ -2710,31 +4458,32 @@ TclExecuteByteCode( */ case INST_LOR: - case INST_LAND: - { + case INST_LAND: { /* * Operands must be boolean or numeric. No int->double conversions are * performed. */ int i1, i2, iResult; - Tcl_Obj *value2Ptr = *tosPtr; - Tcl_Obj *valuePtr = *(tosPtr - 1); - result = TclGetBooleanFromObj(NULL, valuePtr, &i1); - if (result != TCL_OK) { + value2Ptr = OBJ_AT_TOS; + valuePtr = OBJ_UNDER_TOS; + if (TclGetBooleanFromObj(NULL, valuePtr, &i1) != TCL_OK) { TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(valuePtr), (valuePtr->typePtr? valuePtr->typePtr->name : "null"))); + DECACHE_STACK_INFO(); IllegalExprOperandType(interp, pc, valuePtr); - goto checkForCatch; + CACHE_STACK_INFO(); + goto gotError; } - result = TclGetBooleanFromObj(NULL, value2Ptr, &i2); - if (result != TCL_OK) { + if (TclGetBooleanFromObj(NULL, value2Ptr, &i2) != TCL_OK) { TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(value2Ptr), (value2Ptr->typePtr? value2Ptr->typePtr->name : "null"))); + DECACHE_STACK_INFO(); IllegalExprOperandType(interp, pc, value2Ptr); - goto checkForCatch; + CACHE_STACK_INFO(); + goto gotError; } if (*pc == INST_LOR) { @@ -2742,278 +4491,616 @@ TclExecuteByteCode( } else { iResult = (i1 && i2); } - objResultPtr = eePtr->constants[iResult]; - TRACE(("%.20s %.20s => %d\n", O2S(valuePtr), O2S(value2Ptr), iResult)); + objResultPtr = TCONST(iResult); + TRACE(("%.20s %.20s => %d\n", O2S(valuePtr),O2S(value2Ptr),iResult)); NEXT_INST_F(1, 2, 1); } /* - * --------------------------------------------------------- - * Start of INST_LIST and related instructions. + * ----------------------------------------------------------------- + * 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); + } + case INST_COROUTINE_NAME: { + CoroutineData *corPtr = iPtr->execEnvPtr->corPtr; + + TclNewObj(objResultPtr); + if (corPtr && !(corPtr->cmdPtr->flags & CMD_IS_DELETED)) { + Tcl_GetCommandFullName(interp, (Tcl_Command) corPtr->cmdPtr, + objResultPtr); + } + TRACE_WITH_OBJ(("=> "), objResultPtr); + NEXT_INST_F(1, 0, 1); + } + case INST_INFO_LEVEL_NUM: + TclNewIntObj(objResultPtr, iPtr->varFramePtr->level); + TRACE_WITH_OBJ(("=> "), objResultPtr); + NEXT_INST_F(1, 0, 1); + case INST_INFO_LEVEL_ARGS: { + int level; + register CallFrame *framePtr = iPtr->varFramePtr; + register 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), 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) { + 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), NULL); + CACHE_STACK_INFO(); + TRACE_APPEND(("ERROR: not command\n")); + goto gotError; + } + origCmd = TclGetOriginalCommand(cmd); + if (origCmd == NULL) { + origCmd = cmd; + } + TclNewObj(objResultPtr); + Tcl_GetCommandFullName(interp, origCmd, objResultPtr); + TRACE_APPEND(("\"%.30s\"", O2S(OBJ_AT_TOS))); + NEXT_INST_F(1, 1, 1); + } + + /* + * ----------------------------------------------------------------- + * Start of TclOO support instructions. */ - case INST_LIST: { + { + Object *oPtr; + CallFrame *framePtr; + CallContext *contextPtr; + int 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", NULL); + CACHE_STACK_INFO(); + goto gotError; + } + contextPtr = framePtr->clientData; + /* - * Pop the opnd (objc) top stack elements into a new list obj and then - * decrement their ref counts. + * Call out to get the name; it's expensive to compute but cached. */ - int opnd; + objResultPtr = TclOOObjectName(interp, contextPtr->oPtr); + TRACE_WITH_OBJ(("=> "), objResultPtr); + NEXT_INST_F(1, 0, 1); - opnd = TclGetUInt4AtPtr(pc+1); - objResultPtr = Tcl_NewListObj(opnd, (tosPtr - (opnd-1))); - TRACE_WITH_OBJ(("%u => ", opnd), objResultPtr); - NEXT_INST_V(5, opnd, 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", NULL); + CACHE_STACK_INFO(); + goto gotError; + } + contextPtr = framePtr->clientData; - case INST_LIST_LENGTH: { - Tcl_Obj *valuePtr; - int length; + 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; + int 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", NULL); + CACHE_STACK_INFO(); + goto gotError; + } - valuePtr = *tosPtr; + 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, "%d: (%u) invoking ", + iPtr->numLevels, + (unsigned)(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; + } + } - result = Tcl_ListObjLength(interp, valuePtr, &length); - if (result != TCL_OK) { - TRACE_WITH_OBJ(("%.30s => ERROR: ", O2S(valuePtr)), - Tcl_GetObjResult(interp)); - goto checkForCatch; + if (contextPtr->callPtr->flags & CONSTRUCTOR) { + methodType = "constructor"; + } else if (contextPtr->callPtr->flags & DESTRUCTOR) { + methodType = "destructor"; + } else { + methodType = "method"; + } + + TRACE_APPEND(("ERROR: \"%.30s\" not on reachable chain\n", + O2S(valuePtr))); + for (i=contextPtr->index ; i>=0 ; 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", + 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", NULL); + CACHE_STACK_INFO(); + goto gotError; } - TclNewIntObj(objResultPtr, length); - TRACE(("%.20s => %d\n", O2S(valuePtr), length)); + + 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", NULL); + CACHE_STACK_INFO(); + goto gotError; + } + contextPtr = 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", 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, "%d: (%u) invoking ", + iPtr->numLevels, (unsigned)(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*/ + } + + doInvokeNext: + bcFramePtr->data.tebc.pc = (char *) pc; + iPtr->cmdFramePtr = bcFramePtr; + + if (iPtr->flags & INTERP_DEBUG_FRAME) { + ArgumentBCEnter(interp, codePtr, TD, pc, opnd, objv); + } + + pcAdjustment = 2; + cleanup = opnd; + DECACHE_STACK_INFO(); + iPtr->varFramePtr = framePtr->callerVarPtr; + pc += pcAdjustment; + TEBC_YIELD(); + + 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; + } else { + oPtr->flags &= ~FILTER_HANDLING; + } + + { + register 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; + } + + /* + * 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); } - case INST_LIST_INDEX: { - /*** lindex with objc == 3 ***/ + /* + * End of TclOO support instructions. + * ----------------------------------------------------------------- + * Start of INST_LIST and related instructions. + */ - Tcl_Obj *valuePtr, *value2Ptr; + { + int index, numIndices, fromIdx, toIdx; + int nocase, match, length2, cflags, s1len, s2len; + const char *s1, *s2; + case INST_LIST: /* - * Pop the two operands + * Pop the opnd (objc) top stack elements into a new list obj and then + * decrement their ref counts. */ - value2Ptr = *tosPtr; - valuePtr = *(tosPtr - 1); + 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(("%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))); /* - * Extract the desired list element + * Extract the desired list element. */ + if ((TclListObjGetElements(interp, valuePtr, &objc, &objv) == TCL_OK) + && (value2Ptr->typePtr != &tclListType) + && (TclGetIntForIndexM(NULL , value2Ptr, objc-1, + &index) == TCL_OK)) { + TclDecrRefCount(value2Ptr); + tosPtr--; + pcAdjustment = 1; + goto lindexFastPath; + } + objResultPtr = TclLindexList(interp, valuePtr, value2Ptr); - if (objResultPtr == NULL) { - TRACE_WITH_OBJ(("%.30s %.30s => ERROR: ", O2S(valuePtr), O2S(value2Ptr)), - Tcl_GetObjResult(interp)); - result = TCL_ERROR; - goto checkForCatch; + if (!objResultPtr) { + TRACE_ERROR(interp); + goto gotError; } /* - * Stash the list element on the stack + * Stash the list element on the stack. */ - TRACE(("%.20s %.20s => %s\n", - O2S(valuePtr), O2S(value2Ptr), O2S(objResultPtr))); - NEXT_INST_F(1, 2, -1); /* already has the correct refCount */ - } - - 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 */ - int listc, idx, opnd; - Tcl_Obj **listv; - Tcl_Obj *valuePtr; + case INST_LIST_INDEX_IMM: /* lindex with objc==3 and index in bytecode + * stream */ /* - * Pop the list and get the index + * Pop the list and get the index. */ - valuePtr = *tosPtr; + valuePtr = OBJ_AT_TOS; opnd = TclGetInt4AtPtr(pc+1); + TRACE(("\%.30s\" %d => ", O2S(valuePtr), opnd)); /* * Get the contents of the list, making sure that it really is a list * in the process. */ - result = Tcl_ListObjGetElements(interp, valuePtr, &listc, &listv); - if (result != TCL_OK) { - TRACE_WITH_OBJ(("\"%.30s\" %d => ERROR: ", O2S(valuePtr), opnd), - Tcl_GetObjResult(interp)); - goto checkForCatch; + if (TclListObjGetElements(interp, valuePtr, &objc, &objv) != TCL_OK) { + TRACE_ERROR(interp); + goto gotError; } /* - * Select the list item based on the index. Negative operand means + * Select the list item based on the index. Negative operand means * end-based indexing. */ if (opnd < -1) { - idx = opnd+1 + listc; + index = opnd+1 + objc; } else { - idx = opnd; + index = opnd; } - if (idx >= 0 && idx < listc) { - objResultPtr = listv[idx]; + pcAdjustment = 5; + + lindexFastPath: + if (index >= 0 && index < objc) { + objResultPtr = objv[index]; } else { TclNewObj(objResultPtr); } - TRACE_WITH_OBJ(("\"%.30s\" %d => ", O2S(valuePtr), opnd), objResultPtr); - NEXT_INST_F(5, 1, 1); - } + TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr))); + NEXT_INST_F(pcAdjustment, 1, 1); - case INST_LIST_INDEX_MULTI: { + case INST_LIST_INDEX_MULTI: /* 'lindex' with multiple index args */ /* - * 'lindex' with multiple index args: - * * Determine the count of index args. */ - int numIdx, opnd; - opnd = TclGetUInt4AtPtr(pc+1); - numIdx = opnd-1; + numIndices = opnd-1; /* * Do the 'lindex' operation. */ - objResultPtr = TclLindexFlat(interp, *(tosPtr - numIdx), - numIdx, tosPtr - numIdx + 1); - - /* - * Check for errors - */ - if (objResultPtr == NULL) { - TRACE_WITH_OBJ(("%d => ERROR: ", opnd), Tcl_GetObjResult(interp)); - result = TCL_ERROR; - goto checkForCatch; + TRACE(("%d => ", opnd)); + objResultPtr = TclLindexFlat(interp, OBJ_AT_DEPTH(numIndices), + numIndices, &OBJ_AT_DEPTH(numIndices - 1)); + if (!objResultPtr) { + TRACE_ERROR(interp); + goto gotError; } /* - * Set result + * Set result. */ - TRACE(("%d => %s\n", opnd, O2S(objResultPtr))); + + TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr))); NEXT_INST_V(5, opnd, -1); - } - case INST_LSET_FLAT: { + case INST_LSET_FLAT: /* - * Lset with 3, 5, or more args. Get the number of index args. + * Lset with 3, 5, or more args. Get the number of index args. */ - int numIdx,opnd; - Tcl_Obj *valuePtr, *value2Ptr; opnd = TclGetUInt4AtPtr(pc + 1); - numIdx = opnd - 2; + numIndices = opnd - 2; + TRACE(("%d => ", opnd)); /* - * Get the old value of variable, and remove the stack ref. This is + * Get the old value of variable, and remove the stack ref. This is * safe because the variable still references the object; the ref - * count will never go zero here. + * count will never go zero here - we can use the smaller macro + * Tcl_DecrRefCount. */ - value2Ptr = POP_OBJECT(); - TclDecrRefCount(value2Ptr); /* This one should be done here */ - /* - * Get the new element value. - */ - valuePtr = *tosPtr; + valuePtr = POP_OBJECT(); + Tcl_DecrRefCount(valuePtr); /* This one should be done here */ /* - * Compute the new variable value + * Compute the new variable value. */ - objResultPtr = TclLsetFlat(interp, value2Ptr, numIdx, - tosPtr - numIdx, valuePtr); - /* - * Check for errors - */ - if (objResultPtr == NULL) { - TRACE_WITH_OBJ(("%d => ERROR: ", opnd), Tcl_GetObjResult(interp)); - result = TCL_ERROR; - goto checkForCatch; + objResultPtr = TclLsetFlat(interp, valuePtr, numIndices, + &OBJ_AT_DEPTH(numIndices), OBJ_AT_TOS); + if (!objResultPtr) { + TRACE_ERROR(interp); + goto gotError; } /* - * Set result + * Set result. */ - TRACE(("%d => %s\n", opnd, O2S(objResultPtr))); - NEXT_INST_V(5, (numIdx+1), -1); - } - case INST_LSET_LIST: { - /* - * 'lset' with 4 args. - */ - - Tcl_Obj *objPtr, *valuePtr, *value2Ptr; + TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr))); + NEXT_INST_V(5, numIndices+1, -1); + case INST_LSET_LIST: /* 'lset' with 4 args */ /* - * Get the old value of variable, and remove the stack ref. This is + * Get the old value of variable, and remove the stack ref. This is * safe because the variable still references the object; the ref - * count will never go zero here. + * count will never go zero here - we can use the smaller macro + * Tcl_DecrRefCount. */ + objPtr = POP_OBJECT(); - TclDecrRefCount(objPtr); /* This one should be done here */ + Tcl_DecrRefCount(objPtr); /* This one should be done here. */ /* - * Get the new element value, and the index list + * Get the new element value, and the index list. */ - valuePtr = *tosPtr; - value2Ptr = *(tosPtr - 1); - /* - * Compute the new variable value - */ - objResultPtr = TclLsetList(interp, objPtr, value2Ptr, valuePtr); + valuePtr = OBJ_AT_TOS; + value2Ptr = OBJ_UNDER_TOS; + TRACE(("\"%.30s\" \"%.30s\" \"%.30s\" => ", + O2S(value2Ptr), O2S(valuePtr), O2S(objPtr))); /* - * Check for errors + * Compute the new variable value. */ - if (objResultPtr == NULL) { - TRACE_WITH_OBJ(("\"%.30s\" => ERROR: ", O2S(value2Ptr)), - Tcl_GetObjResult(interp)); - result = TCL_ERROR; - goto checkForCatch; + + objResultPtr = TclLsetList(interp, objPtr, value2Ptr, valuePtr); + if (!objResultPtr) { + TRACE_ERROR(interp); + goto gotError; } /* - * Set result + * Set result. */ - TRACE(("=> %s\n", O2S(objResultPtr))); - NEXT_INST_F(1, 2, -1); - } - case INST_LIST_RANGE_IMM: { - /*** lrange with objc==4 and both indices in bytecode stream ***/ + TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr))); + NEXT_INST_F(1, 2, -1); - int listc, fromIdx, toIdx; - Tcl_Obj **listv; - Tcl_Obj *valuePtr; + case INST_LIST_RANGE_IMM: /* lrange with objc==4 and both indices in + * bytecode stream */ /* - * Pop the list and get the indices + * Pop the list and get the indices. */ - valuePtr = *tosPtr; + + 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 contents of the list, making sure that it really is a list * in the process. */ - result = Tcl_ListObjGetElements(interp, valuePtr, &listc, &listv); - if (result != TCL_OK) { - TRACE_WITH_OBJ(("\"%.30s\" %d %d => ERROR: ", O2S(valuePtr), - fromIdx, toIdx), Tcl_GetObjResult(interp)); - goto checkForCatch; + + if (TclListObjGetElements(interp, valuePtr, &objc, &objv) != TCL_OK) { + TRACE_ERROR(interp); + goto gotError; } /* * Skip a lot of work if we're about to throw the result away (common - * with uses of [lassign].) + * with uses of [lassign]). */ + #ifndef TCL_COMPILE_DEBUG if (*(pc+9) == INST_POP) { NEXT_INST_F(10, 1, 0); @@ -3023,88 +5110,103 @@ TclExecuteByteCode( /* * Adjust the indices for end-based handling. */ + if (fromIdx < -1) { - fromIdx += 1+listc; + fromIdx += 1+objc; if (fromIdx < -1) { fromIdx = -1; } - } else if (fromIdx > listc) { - fromIdx = listc; + } else if (fromIdx > objc) { + fromIdx = objc; } if (toIdx < -1) { - toIdx += 1+listc; + toIdx += 1 + objc; if (toIdx < -1) { toIdx = -1; } - } else if (toIdx > listc) { - toIdx = listc; + } else if (toIdx > objc) { + toIdx = objc; } /* * 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<=toIdx && fromIdx<listc && toIdx>=0) { - if (fromIdx<0) { + + if (fromIdx<=toIdx && fromIdx<objc && toIdx>=0) { + if (fromIdx < 0) { fromIdx = 0; } - if (toIdx >= listc) { - toIdx = listc-1; + if (toIdx >= objc) { + toIdx = objc-1; + } + if (fromIdx == 0 && toIdx != objc-1 && !Tcl_IsShared(valuePtr)) { + /* + * BEWARE! This is looking inside the implementation of the + * list type. + */ + + List *listPtr = valuePtr->internalRep.twoPtrValue.ptr1; + + if (listPtr->refCount == 1) { + for (index=toIdx+1; index<objc ; index++) { + TclDecrRefCount(objv[index]); + } + listPtr->elemCount = toIdx+1; + listPtr->canonicalFlag = 1; + TclInvalidateStringRep(valuePtr); + TRACE_APPEND(("%.30s\n", O2S(valuePtr))); + NEXT_INST_F(9, 0, 0); + } } - objResultPtr = Tcl_NewListObj(toIdx-fromIdx+1, listv+fromIdx); + objResultPtr = Tcl_NewListObj(toIdx-fromIdx+1, objv+fromIdx); } else { TclNewObj(objResultPtr); } - TRACE_WITH_OBJ(("\"%.30s\" %d %d => ", O2S(valuePtr), - TclGetInt4AtPtr(pc+1), TclGetInt4AtPtr(pc+5)), objResultPtr); + TRACE_APPEND(("\"%.30s\"", O2S(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. */ + value2Ptr = OBJ_AT_TOS; + valuePtr = OBJ_UNDER_TOS; - int found, s1len, s2len, llen, i; - Tcl_Obj *valuePtr, *value2Ptr, *o; - char *s1, *s2; + 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) { + int i = 0; + Tcl_Obj *o; - value2Ptr = *tosPtr; - valuePtr = *(tosPtr - 1); + /* + * An empty list doesn't match anything. + */ - /* TODO: Consider more efficient tests than strcmp() */ - s1 = Tcl_GetStringFromObj(valuePtr, &s1len); - result = Tcl_ListObjLength(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 { Tcl_ListObjIndex(NULL, value2Ptr, i, &o); if (o != NULL) { - s2 = Tcl_GetStringFromObj(o, &s2len); + s2 = TclGetStringFromObj(o, &s2len); } else { s2 = ""; + s2len = 0; } if (s1len == s2len) { - found = (strcmp(s1, s2) == 0); + match = (memcmp(s1, s2, s1len) == 0); } i++; - } while (i < llen && found == 0); + } while (i < length && match == 0); } if (*pc == INST_LIST_NOT_IN) { - found = !found; + match = !match; } - TRACE(("%.20s %.20s => %d\n", O2S(valuePtr), O2S(value2Ptr), found)); + TRACE_APPEND(("%d\n", match)); /* * Peep-hole optimisation: if you're about to jump, do jump from here. @@ -3112,284 +5214,640 @@ TclExecuteByteCode( * for branching. */ - 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); + 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); } -#endif - objResultPtr = eePtr->constants[found]; - NEXT_INST_F(0, 2, 1); - } /* * End of INST_LIST and related instructions. - * --------------------------------------------------------- + * ----------------------------------------------------------------- + * Start of string-related instructions. */ case INST_STR_EQ: - case INST_STR_NEQ: { - /* - * String (in)equality check - * TODO: Consider merging into INST_STR_CMP - */ - - int iResult; - Tcl_Obj *valuePtr, *value2Ptr; - - value2Ptr = *tosPtr; - valuePtr = *(tosPtr - 1); + case INST_STR_NEQ: /* String (in)equality check */ + case INST_STR_CMP: /* String compare. */ + stringCompare: + value2Ptr = OBJ_AT_TOS; + valuePtr = OBJ_UNDER_TOS; if (valuePtr == value2Ptr) { + match = 0; + } else { /* - * On the off-chance that the objects are the same, we don't - * really have to think hard about equality. + * We only need to check (in)equality when we have equal length + * strings. We can use memcmp in all (n)eq cases because we + * don't need to worry about lexical LE/BE variance. */ - iResult = (*pc == INST_STR_EQ); - } else { - char *s1, *s2; - int s1len, s2len; - - s1 = Tcl_GetStringFromObj(valuePtr, &s1len); - s2 = Tcl_GetStringFromObj(value2Ptr, &s2len); - if (s1len == s2len) { + typedef int (*memCmpFn_t)(const void*, const void*, size_t); + memCmpFn_t memCmpFn; + int checkEq = ((*pc == INST_EQ) || (*pc == INST_NEQ) + || (*pc == INST_STR_EQ) || (*pc == INST_STR_NEQ)); + + if (TclIsPureByteArray(valuePtr) + && TclIsPureByteArray(value2Ptr)) { + s1 = (char *) Tcl_GetByteArrayFromObj(valuePtr, &s1len); + s2 = (char *) Tcl_GetByteArrayFromObj(value2Ptr, &s2len); + memCmpFn = memcmp; + } else if (((valuePtr->typePtr == &tclStringType) + && (value2Ptr->typePtr == &tclStringType))) { /* - * We only need to check (in)equality when we have equal - * length strings. + * 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. */ - if (*pc == INST_STR_NEQ) { - iResult = (strcmp(s1, s2) != 0); + s1len = Tcl_GetCharLength(valuePtr); + s2len = Tcl_GetCharLength(value2Ptr); + if ((s1len == valuePtr->length) + && (s2len == value2Ptr->length)) { + s1 = valuePtr->bytes; + s2 = value2Ptr->bytes; + memCmpFn = memcmp; } else { - /* INST_STR_EQ */ - iResult = (strcmp(s1, s2) == 0); + s1 = (char *) Tcl_GetUnicode(valuePtr); + s2 = (char *) Tcl_GetUnicode(value2Ptr); + if ( +#ifdef WORDS_BIGENDIAN + 1 +#else + checkEq +#endif + ) { + memCmpFn = memcmp; + s1len *= sizeof(Tcl_UniChar); + s2len *= sizeof(Tcl_UniChar); + } else { + memCmpFn = (memCmpFn_t) Tcl_UniCharNcmp; + } } } else { - iResult = (*pc == INST_STR_NEQ); - } - } - - 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 = eePtr->constants[iResult]; - NEXT_INST_F(0, 2, 1); - } - - case INST_STR_CMP: { - /* - * String compare - */ - - CONST char *s1, *s2; - int s1len, s2len, iResult; - Tcl_Obj *valuePtr, *value2Ptr; - - stringCompare: - value2Ptr = *tosPtr; - valuePtr = *(tosPtr - 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). - */ + /* + * strcmp can't do a simple memcmp in order to handle the + * special Tcl \xC0\x80 null encoding for utf-8. + */ - iResult = s1len = s2len = 0; - } else if ((valuePtr->typePtr == &tclByteArrayType) - && (value2Ptr->typePtr == &tclByteArrayType)) { - s1 = (char *) Tcl_GetByteArrayFromObj(valuePtr, &s1len); - s2 = (char *) Tcl_GetByteArrayFromObj(value2Ptr, &s2len); - iResult = memcmp(s1, s2, - (size_t) ((s1len < s2len) ? s1len : s2len)); - } else if (((valuePtr->typePtr == &tclStringType) - && (value2Ptr->typePtr == &tclStringType))) { - /* - * Do a unicode-specific comparison if both of the args are of - * String type. If the char length == byte length, we can do a - * memcmp. In benchmark testing this proved the most efficient - * check between the unicode and string comparison operations. - */ + s1 = TclGetStringFromObj(valuePtr, &s1len); + s2 = TclGetStringFromObj(value2Ptr, &s2len); + if (checkEq) { + memCmpFn = memcmp; + } else { + memCmpFn = (memCmpFn_t) TclpUtfNcmp2; + } + } - 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)); + if (checkEq && (s1len != s2len)) { + match = 1; } else { - iResult = TclUniCharNcmp(Tcl_GetUnicode(valuePtr), - Tcl_GetUnicode(value2Ptr), - (unsigned) ((s1len < s2len) ? s1len : s2len)); + /* + * The comparison function should compare up to the minimum + * byte length only. + */ + match = memCmpFn(s1, s2, + (size_t) ((s1len < s2len) ? s1len : s2len)); + if (match == 0) { + match = s1len - s2len; + } } - } else { - /* - * We can't do a simple memcmp in order to handle the special Tcl - * \xC0\x80 null encoding for utf-8. - */ - s1 = Tcl_GetStringFromObj(valuePtr, &s1len); - s2 = Tcl_GetStringFromObj(value2Ptr, &s2len); - iResult = TclpUtfNcmp2(s1, s2, - (size_t) ((s1len < s2len) ? s1len : s2len)); } /* * Make sure only -1,0,1 is returned * TODO: consider peephole opt. */ - if (iResult == 0) { - iResult = s1len - s2len; - } if (*pc != INST_STR_CMP) { - /* Take care of the opcodes that goto'ed into here */ + /* + * Take care of the opcodes that goto'ed into here. + */ + switch (*pc) { + case INST_STR_EQ: case INST_EQ: - iResult = (iResult == 0); + match = (match == 0); break; + case INST_STR_NEQ: case INST_NEQ: - iResult = (iResult != 0); + match = (match != 0); break; case INST_LT: - iResult = (iResult < 0); + match = (match < 0); break; case INST_GT: - iResult = (iResult > 0); + match = (match > 0); break; case INST_LE: - iResult = (iResult <= 0); + match = (match <= 0); break; case INST_GE: - iResult = (iResult >= 0); + match = (match >= 0); break; } } - if (iResult < 0) { - TclNewIntObj(objResultPtr, -1); - TRACE(("%.20s %.20s => %d\n", O2S(valuePtr), O2S(value2Ptr), -1)); + + 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 = Tcl_GetCharLength(valuePtr); + TclNewIntObj(objResultPtr, length); + TRACE(("\"%.20s\" => %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); + TclFreeIntRep(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); + TclFreeIntRep(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); + TclFreeIntRep(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 calulate what 'end' means. + */ + + length = Tcl_GetCharLength(valuePtr); + if (TclGetIntForIndexM(interp, value2Ptr, length-1, &index)!=TCL_OK) { + TRACE_ERROR(interp); + goto gotError; + } + + if ((index < 0) || (index >= length)) { + TclNewObj(objResultPtr); + } else if (TclIsPureByteArray(valuePtr)) { + objResultPtr = Tcl_NewByteArrayObj( + Tcl_GetByteArrayFromObj(valuePtr, &length)+index, 1); + } else if (valuePtr->bytes && length == valuePtr->length) { + objResultPtr = Tcl_NewStringObj((const char *) + valuePtr->bytes+index, 1); } else { - objResultPtr = eePtr->constants[(iResult>0)]; - TRACE(("%.20s %.20s => %d\n", O2S(valuePtr), O2S(value2Ptr), - (iResult > 0))); + char buf[TCL_UTF_MAX]; + Tcl_UniChar ch = Tcl_GetUniChar(valuePtr, index); + + /* + * This could be: Tcl_NewUnicodeObj((const Tcl_UniChar *)&ch, 1) + * but creating the object as a string seems to be faster in + * practical use. + */ + + length = Tcl_UniCharToUtf(ch, buf); + objResultPtr = Tcl_NewStringObj(buf, length); } + TRACE_APPEND(("\"%s\"\n", O2S(objResultPtr))); NEXT_INST_F(1, 2, 1); - } - case INST_STR_LEN: { - int length; - Tcl_Obj *valuePtr; + case INST_STR_RANGE: + TRACE(("\"%.20s\" %.20s %.20s =>", + O2S(OBJ_AT_DEPTH(2)), O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS))); + length = Tcl_GetCharLength(OBJ_AT_DEPTH(2)) - 1; + if (TclGetIntForIndexM(interp, OBJ_UNDER_TOS, length, + &fromIdx) != TCL_OK + || TclGetIntForIndexM(interp, OBJ_AT_TOS, length, + &toIdx) != TCL_OK) { + TRACE_ERROR(interp); + goto gotError; + } - valuePtr = *tosPtr; + if (fromIdx < 0) { + fromIdx = 0; + } + if (toIdx >= length) { + toIdx = length; + } + if (toIdx >= fromIdx) { + objResultPtr = Tcl_GetRange(OBJ_AT_DEPTH(2), fromIdx, toIdx); + } else { + TclNewObj(objResultPtr); + } + TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr))); + NEXT_INST_V(1, 3, 1); + + case INST_STR_RANGE_IMM: + valuePtr = OBJ_AT_TOS; + fromIdx = TclGetInt4AtPtr(pc+1); + toIdx = TclGetInt4AtPtr(pc+5); + length = Tcl_GetCharLength(valuePtr); + TRACE(("\"%.20s\" %d %d => ", O2S(valuePtr), fromIdx, toIdx)); + + /* + * Adjust indices for end-based indexing. + */ - if (valuePtr->typePtr == &tclByteArrayType) { - (void) Tcl_GetByteArrayFromObj(valuePtr, &length); + if (fromIdx < -1) { + fromIdx += 1 + length; + if (fromIdx < 0) { + fromIdx = 0; + } + } else if (fromIdx >= length) { + fromIdx = length; + } + if (toIdx < -1) { + toIdx += 1 + length; + } else if (toIdx >= length) { + toIdx = length - 1; + } + + /* + * Check if we can do a sane substring. + */ + + if (fromIdx <= toIdx) { + objResultPtr = Tcl_GetRange(valuePtr, fromIdx, toIdx); } else { - length = Tcl_GetCharLength(valuePtr); + TclNewObj(objResultPtr); + } + TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); + NEXT_INST_F(9, 1, 1); + + { + Tcl_UniChar *ustring1, *ustring2, *ustring3, *end, *p; + int length3; + Tcl_Obj *value3Ptr; + + case INST_STR_REPLACE: + value3Ptr = POP_OBJECT(); + valuePtr = OBJ_AT_DEPTH(2); + length = Tcl_GetCharLength(valuePtr) - 1; + TRACE(("\"%.20s\" %s %s \"%.20s\" => ", O2S(valuePtr), + O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS), O2S(value3Ptr))); + if (TclGetIntForIndexM(interp, OBJ_UNDER_TOS, length, + &fromIdx) != TCL_OK + || TclGetIntForIndexM(interp, OBJ_AT_TOS, length, + &toIdx) != TCL_OK) { + TclDecrRefCount(value3Ptr); + TRACE_ERROR(interp); + goto gotError; + } + TclDecrRefCount(OBJ_AT_TOS); + (void) POP_OBJECT(); + TclDecrRefCount(OBJ_AT_TOS); + (void) POP_OBJECT(); + if (fromIdx < 0) { + fromIdx = 0; + } + + if (fromIdx > toIdx || fromIdx > length) { + TRACE_APPEND(("\"%.30s\"\n", O2S(valuePtr))); + TclDecrRefCount(value3Ptr); + NEXT_INST_F(1, 0, 0); + } + + if (toIdx > length) { + toIdx = length; + } + + if (fromIdx == 0 && toIdx == length) { + TclDecrRefCount(OBJ_AT_TOS); + OBJ_AT_TOS = value3Ptr; + TRACE_APPEND(("\"%.30s\"\n", O2S(value3Ptr))); + NEXT_INST_F(1, 0, 0); + } + + length3 = Tcl_GetCharLength(value3Ptr); + + /* + * Remove substring. In-place. + */ + + if (length3 == 0 && !Tcl_IsShared(valuePtr) && toIdx == length) { + TclDecrRefCount(value3Ptr); + Tcl_SetObjLength(valuePtr, fromIdx); + TRACE_APPEND(("\"%.30s\"\n", O2S(valuePtr))); + NEXT_INST_F(1, 0, 0); + } + + /* + * See if we can splice in place. This happens when the number of + * characters being replaced is the same as the number of characters + * in the string to be inserted. + */ + + if (length3 - 1 == toIdx - fromIdx) { + unsigned char *bytes1, *bytes2; + + if (Tcl_IsShared(valuePtr)) { + objResultPtr = Tcl_DuplicateObj(valuePtr); + if (TclIsPureByteArray(objResultPtr) + && TclIsPureByteArray(value3Ptr)) { + bytes1 = Tcl_GetByteArrayFromObj(objResultPtr, NULL); + bytes2 = Tcl_GetByteArrayFromObj(value3Ptr, NULL); + memcpy(bytes1 + fromIdx, bytes2, length3); + } else { + ustring1 = Tcl_GetUnicodeFromObj(objResultPtr, NULL); + ustring2 = Tcl_GetUnicodeFromObj(value3Ptr, NULL); + memcpy(ustring1 + fromIdx, ustring2, + length3 * sizeof(Tcl_UniChar)); + + /* + * Magic! Flush the info in the string internal rep that + * refers to the about-to-be-invalidated UTF-8 rep. This + * sets the 'allocated' field of the String structure to 0 + * to indicate that a new buffer needs to be allocated. + * This is safe; we know we've got a tclStringTypePtr set + * at this point (post Tcl_GetUnicodeFromObj). + */ + + ((int *) objResultPtr->internalRep.otherValuePtr)[1] = 0; + } + Tcl_InvalidateStringRep(objResultPtr); + TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr))); + NEXT_INST_F(1, 1, 1); + } else { + if (TclIsPureByteArray(valuePtr) + && TclIsPureByteArray(value3Ptr)) { + bytes1 = Tcl_GetByteArrayFromObj(valuePtr, NULL); + bytes2 = Tcl_GetByteArrayFromObj(value3Ptr, NULL); + memcpy(bytes1 + fromIdx, bytes2, length3); + } else { + ustring1 = Tcl_GetUnicodeFromObj(valuePtr, NULL); + ustring2 = Tcl_GetUnicodeFromObj(value3Ptr, NULL); + memcpy(ustring1 + fromIdx, ustring2, + length3 * sizeof(Tcl_UniChar)); + + /* + * Magic! Flush the info in the string internal rep that + * refers to the about-to-be-invalidated UTF-8 rep. This + * sets the 'allocated' field of the String structure to 0 + * to indicate that a new buffer needs to be allocated. + * This is safe; we know we've got a tclStringTypePtr set + * at this point (post Tcl_GetUnicodeFromObj). + */ + + ((int *) objResultPtr->internalRep.otherValuePtr)[1] = 0; + } + Tcl_InvalidateStringRep(valuePtr); + TRACE_APPEND(("\"%.30s\"\n", O2S(valuePtr))); + NEXT_INST_F(1, 0, 0); + } } - TclNewIntObj(objResultPtr, length); - TRACE(("%.20s => %d\n", O2S(valuePtr), length)); - NEXT_INST_F(1, 1, 1); - } - case INST_STR_INDEX: { /* - * String compare + * Get the unicode representation; this is where we guarantee to lose + * bytearrays. */ - int index, length; - char *bytes; - Tcl_Obj *valuePtr, *value2Ptr; - bytes = NULL; /* lint */ - value2Ptr = *tosPtr; - valuePtr = *(tosPtr - 1); + ustring1 = Tcl_GetUnicodeFromObj(valuePtr, &length); + length--; /* - * 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. + * Remove substring using copying. */ - if (valuePtr->typePtr == &tclByteArrayType) { - bytes = (char *)Tcl_GetByteArrayFromObj(valuePtr, &length); + if (length3 == 0) { + if (fromIdx > 0) { + objResultPtr = Tcl_NewUnicodeObj(ustring1, fromIdx); + if (toIdx < length) { + Tcl_AppendUnicodeToObj(objResultPtr, ustring1 + toIdx + 1, + length - toIdx); + } + } else { + objResultPtr = Tcl_NewUnicodeObj(ustring1 + toIdx + 1, + length - toIdx); + } + TclDecrRefCount(value3Ptr); + TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr))); + NEXT_INST_F(1, 1, 1); + } + + /* + * Splice string pieces by full copying. + */ + + if (fromIdx > 0) { + objResultPtr = Tcl_NewUnicodeObj(ustring1, fromIdx); + Tcl_AppendObjToObj(objResultPtr, value3Ptr); + if (toIdx < length) { + Tcl_AppendUnicodeToObj(objResultPtr, ustring1 + toIdx + 1, + length - toIdx); + } + } else if (Tcl_IsShared(value3Ptr)) { + objResultPtr = Tcl_DuplicateObj(value3Ptr); + if (toIdx < length) { + Tcl_AppendUnicodeToObj(objResultPtr, ustring1 + toIdx + 1, + length - toIdx); + } } else { /* - * Get Unicode char length to calulate what 'end' means. + * Be careful with splicing the stack in this case; we have a + * refCount:1 object in value3Ptr and we want to append to it and + * make it be the refCount:1 object at the top of the stack + * afterwards. [Bug 82e7f67325] */ - length = Tcl_GetCharLength(valuePtr); - } - result = TclGetIntForIndex(interp, value2Ptr, length - 1, &index); - if (result != TCL_OK) { - goto checkForCatch; + if (toIdx < length) { + Tcl_AppendUnicodeToObj(value3Ptr, ustring1 + toIdx + 1, + length - toIdx); + } + TRACE_APPEND(("\"%.30s\"\n", O2S(value3Ptr))); + TclDecrRefCount(valuePtr); + OBJ_AT_TOS = value3Ptr; /* Tricky! */ + NEXT_INST_F(1, 0, 0); } + TclDecrRefCount(value3Ptr); + TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr))); + NEXT_INST_F(1, 1, 1); - if ((index >= 0) && (index < length)) { - if (valuePtr->typePtr == &tclByteArrayType) { - objResultPtr = Tcl_NewByteArrayObj((unsigned char *) - (&bytes[index]), 1); - } else if (valuePtr->bytes && length == valuePtr->length) { - objResultPtr = Tcl_NewStringObj((CONST char *) - (&valuePtr->bytes[index]), 1); + 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 = Tcl_GetUnicodeFromObj(valuePtr, &length); + if (length == 0) { + objResultPtr = valuePtr; + goto doneStringMap; + } + ustring2 = Tcl_GetUnicodeFromObj(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 { - char buf[TCL_UTF_MAX]; - Tcl_UniChar ch; + objResultPtr = value3Ptr; + } + goto doneStringMap; + } + ustring3 = Tcl_GetUnicodeFromObj(value3Ptr, &length3); + + objResultPtr = Tcl_NewUnicodeObj(ustring1, 0); + p = ustring1; + end = ustring1 + length; + for (; ustring1 < end; ustring1++) { + if ((*ustring1 == *ustring2) && (length2==1 || + memcmp(ustring1, ustring2, sizeof(Tcl_UniChar) * length2) + == 0)) { + if (p != ustring1) { + Tcl_AppendUnicodeToObj(objResultPtr, p, ustring1-p); + p = ustring1 + length2; + } else { + p += length2; + } + ustring1 = p - 1; + + Tcl_AppendUnicodeToObj(objResultPtr, ustring3, length3); + } + } + if (p != ustring1) { + /* + * Put the rest of the unmapped chars onto result. + */ - ch = Tcl_GetUniChar(valuePtr, index); + Tcl_AppendUnicodeToObj(objResultPtr, p, ustring1 - p); + } + doneStringMap: + TRACE_WITH_OBJ(("%.20s %.20s %.20s => ", + O2S(value2Ptr), O2S(value3Ptr), O2S(valuePtr)), objResultPtr); + NEXT_INST_V(1, 3, 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. - */ + case INST_STR_FIND: + ustring1 = Tcl_GetUnicodeFromObj(OBJ_AT_TOS, &length); /* Haystack */ + ustring2 = Tcl_GetUnicodeFromObj(OBJ_UNDER_TOS, &length2);/* Needle */ - length = Tcl_UniCharToUtf(ch, buf); - objResultPtr = Tcl_NewStringObj(buf, length); + match = -1; + if (length2 > 0 && length2 <= length) { + end = ustring1 + length - length2 + 1; + for (p=ustring1 ; p<end ; p++) { + if ((*p == *ustring2) && + memcmp(ustring2,p,sizeof(Tcl_UniChar)*length2) == 0) { + match = p - ustring1; + break; + } } - } else { - TclNewObj(objResultPtr); } - TRACE(("%.20s %.20s => %s\n", O2S(valuePtr), O2S(value2Ptr), - O2S(objResultPtr))); + TRACE(("%.20s %.20s => %d\n", + O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS), match)); + TclNewIntObj(objResultPtr, match); NEXT_INST_F(1, 2, 1); - } - case INST_STR_MATCH: { - int nocase, match; - Tcl_Obj *valuePtr, *value2Ptr; + case INST_STR_FIND_LAST: + ustring1 = Tcl_GetUnicodeFromObj(OBJ_AT_TOS, &length); /* Haystack */ + ustring2 = Tcl_GetUnicodeFromObj(OBJ_UNDER_TOS, &length2);/* Needle */ + + match = -1; + if (length2 > 0 && length2 <= length) { + for (p=ustring1+length-length2 ; p>=ustring1 ; p--) { + if ((*p == *ustring2) && + memcmp(ustring2,p,sizeof(Tcl_UniChar)*length2) == 0) { + match = p - ustring1; + break; + } + } + } + + TRACE(("%.20s %.20s => %d\n", + O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS), match)); + + TclNewIntObj(objResultPtr, match); + 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 = Tcl_GetUnicodeFromObj(valuePtr, &length); + match = 1; + if (length > 0) { + end = ustring1 + length; + for (p=ustring1 ; p<end ; p++) { + if (!tclStringClassTable[opnd].comparator(*p)) { + match = 0; + break; + } + } + } + TRACE_APPEND(("%d\n", match)); + JUMP_PEEPHOLE_F(match, 2, 1); + } - nocase = TclGetInt1AtPtr(pc+1); - valuePtr = *tosPtr; /* String */ - value2Ptr = *(tosPtr - 1); /* Pattern */ + case INST_STR_MATCH: + nocase = TclGetInt1AtPtr(pc+1); + valuePtr = OBJ_AT_TOS; /* String */ + value2Ptr = OBJ_UNDER_TOS; /* Pattern */ /* * Check that at least one of the objects is Unicode before promoting @@ -3399,12 +5857,17 @@ TclExecuteByteCode( if ((valuePtr->typePtr == &tclStringType) || (value2Ptr->typePtr == &tclStringType)) { Tcl_UniChar *ustring1, *ustring2; - int length1, length2; - ustring1 = Tcl_GetUnicodeFromObj(valuePtr, &length1); + ustring1 = Tcl_GetUnicodeFromObj(valuePtr, &length); ustring2 = Tcl_GetUnicodeFromObj(value2Ptr, &length2); - match = TclUniCharMatch(ustring1, length1, ustring2, length2, + match = TclUniCharMatch(ustring1, length, ustring2, length2, nocase); + } else if (TclIsPureByteArray(valuePtr) && !nocase) { + unsigned char *bytes1, *bytes2; + + bytes1 = Tcl_GetByteArrayFromObj(valuePtr, &length); + bytes2 = Tcl_GetByteArrayFromObj(value2Ptr, &length2); + match = TclByteArrayMatch(bytes1, length, bytes2, length2, 0); } else { match = Tcl_StringCaseMatch(TclGetString(valuePtr), TclGetString(value2Ptr), nocase); @@ -3413,37 +5876,182 @@ TclExecuteByteCode( /* * 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)); - objResultPtr = eePtr->constants[match]; - NEXT_INST_F(2, 2, 1); + + /* + * Peep-hole optimisation: if you're about to jump, do jump from here. + */ + + JUMP_PEEPHOLE_F(match, 2, 2); + + { + const char *string1, *string2; + int 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 = TclTrimLeft(string1, length, string2, length2); + if (trim1 < length) { + trim2 = TclTrimRight(string1, length, string2, length2); + } else { + trim2 = 0; + } + 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); + } } + case INST_REGEXP: + 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; + } + 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. + */ + + JUMP_PEEPHOLE_F(match, 2, 2); + } + + /* + * End of string-related instructions. + * ----------------------------------------------------------------- + * Start of numeric operator instructions. + */ + + { + ClientData ptr1, ptr2; + int type1, type2; + long l1, l2, lResult; + + case INST_NUM_TYPE: + if (GetNumberFromObj(NULL, OBJ_AT_TOS, &ptr1, &type1) != TCL_OK) { + type1 = 0; + } else if (type1 == TCL_NUMBER_LONG) { + /* value is between LONG_MIN and LONG_MAX */ + /* [string is integer] is -UINT_MAX to UINT_MAX range */ + int i; + + if (Tcl_GetIntFromObj(NULL, OBJ_AT_TOS, &i) != TCL_OK) { + type1 = TCL_NUMBER_WIDE; + } +#ifndef TCL_WIDE_INT_IS_LONG + } else if (type1 == TCL_NUMBER_WIDE) { + /* value is between WIDE_MIN and WIDE_MAX */ + /* [string is wideinteger] is -UWIDE_MAX to UWIDE_MAX range */ + int i; + if (Tcl_GetIntFromObj(NULL, OBJ_AT_TOS, &i) == TCL_OK) { + type1 = TCL_NUMBER_LONG; + } +#endif + } else if (type1 == TCL_NUMBER_BIG) { + /* value is an integer outside the WIDE_MIN to WIDE_MAX range */ + /* [string is wideinteger] is -UWIDE_MAX to UWIDE_MAX range */ + Tcl_WideInt w; + + if (Tcl_GetWideIntFromObj(NULL, OBJ_AT_TOS, &w) == TCL_OK) { + type1 = TCL_NUMBER_WIDE; + } + } + TclNewIntObj(objResultPtr, type1); + TRACE(("\"%.20s\" => %d\n", O2S(OBJ_AT_TOS), type1)); + NEXT_INST_F(1, 1, 1); + case INST_EQ: case INST_NEQ: case INST_LT: case INST_GT: case INST_LE: case INST_GE: { - Tcl_Obj *valuePtr = *(tosPtr - 1); - Tcl_Obj *value2Ptr = *tosPtr; - 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 + int iResult = 0, compare = 0; + + value2Ptr = OBJ_AT_TOS; + valuePtr = OBJ_UNDER_TOS; if (GetNumberFromObj(NULL, valuePtr, &ptr1, &type1) != TCL_OK) { - /* At least one non-numeric argument - compare as strings */ + /* + * At least one non-numeric argument - compare as strings. + */ + goto stringCompare; } if (type1 == TCL_NUMBER_NAN) { - /* NaN first arg: NaN != to everything, other compares are false */ + /* + * NaN first arg: NaN != to everything, other compares are false. + */ + iResult = (*pc == INST_NEQ); goto foundResult; } @@ -3452,250 +6060,31 @@ TclExecuteByteCode( goto convertComparison; } if (GetNumberFromObj(NULL, value2Ptr, &ptr2, &type2) != TCL_OK) { - /* At least one non-numeric argument - compare as strings */ + /* + * 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 */ + /* + * 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: - if (Tcl_IsShared(value2Ptr)) { - Tcl_GetBignumFromObj(NULL, value2Ptr, &big2); - } else { - Tcl_GetBignumAndClearObj(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); - 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: - if (Tcl_IsShared(value2Ptr)) { - Tcl_GetBignumFromObj(NULL, value2Ptr, &big2); - } else { - Tcl_GetBignumAndClearObj(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; - } - if (Tcl_IsShared(value2Ptr)) { - Tcl_GetBignumFromObj(NULL, value2Ptr, &big2); - } else { - Tcl_GetBignumAndClearObj(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: - if (Tcl_IsShared(valuePtr)) { - Tcl_GetBignumFromObj(NULL, valuePtr, &big1); - } else { - Tcl_GetBignumAndClearObj(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: - if (Tcl_IsShared(value2Ptr)) { - Tcl_GetBignumFromObj(NULL, value2Ptr, &big2); - } else { - Tcl_GetBignumAndClearObj(NULL, value2Ptr, &big2); - } - bigCompare: - compare = mp_cmp(&big1, &big2); - mp_clear(&big1); - mp_clear(&big2); - } + if ((type1 == TCL_NUMBER_LONG) && (type2 == TCL_NUMBER_LONG)) { + l1 = *((const long *)ptr1); + l2 = *((const long *)ptr2); + compare = (l1 < l2) ? MP_LT : ((l1 > l2) ? MP_GT : MP_EQ); + } else { + compare = TclCompareTwoNumbers(valuePtr, value2Ptr); } - /* Turn comparison outcome into appropriate result for opcode */ + /* + * Turn comparison outcome into appropriate result for opcode. + */ convertComparison: switch (*pc) { @@ -3724,1708 +6113,651 @@ TclExecuteByteCode( */ foundResult: - pc++; -#ifndef TCL_COMPILE_DEBUG - switch (*pc) { - case INST_JUMP_FALSE1: - NEXT_INST_F((iResult? 2 : TclGetInt1AtPtr(pc+1)), 2, 0); - case INST_JUMP_TRUE1: - NEXT_INST_F((iResult? TclGetInt1AtPtr(pc+1) : 2), 2, 0); - case INST_JUMP_FALSE4: - NEXT_INST_F((iResult? 5 : TclGetInt4AtPtr(pc+1)), 2, 0); - case INST_JUMP_TRUE4: - NEXT_INST_F((iResult? TclGetInt4AtPtr(pc+1) : 5), 2, 0); - } -#endif - objResultPtr = eePtr->constants[iResult]; - NEXT_INST_F(0, 2, 1); + TRACE(("\"%.20s\" \"%.20s\" => %d\n", O2S(valuePtr), O2S(value2Ptr), + iResult)); + JUMP_PEEPHOLE_F(iResult, 1, 2); } + case INST_MOD: case INST_LSHIFT: - case INST_RSHIFT: { - Tcl_Obj *value2Ptr = *tosPtr; - Tcl_Obj *valuePtr = *(tosPtr - 1); - ClientData ptr1, ptr2; - int invalid, shift, type1, type2; - long l; + case INST_RSHIFT: + case INST_BITOR: + case INST_BITXOR: + case INST_BITAND: + value2Ptr = OBJ_AT_TOS; + valuePtr = OBJ_UNDER_TOS; - result = GetNumberFromObj(NULL, valuePtr, &ptr1, &type1); - if ((result != TCL_OK) - || (type1 == TCL_NUMBER_DOUBLE) || (type1 == TCL_NUMBER_NAN)) { - result = TCL_ERROR; + if ((GetNumberFromObj(NULL, valuePtr, &ptr1, &type1) != TCL_OK) + || (type1==TCL_NUMBER_DOUBLE) || (type1==TCL_NUMBER_NAN)) { TRACE(("%.20s %.20s => ILLEGAL 1st TYPE %s\n", O2S(valuePtr), O2S(value2Ptr), (valuePtr->typePtr? valuePtr->typePtr->name : "null"))); + DECACHE_STACK_INFO(); IllegalExprOperandType(interp, pc, valuePtr); - goto checkForCatch; + CACHE_STACK_INFO(); + goto gotError; } - result = GetNumberFromObj(NULL, value2Ptr, &ptr2, &type2); - if ((result != TCL_OK) - || (type2 == TCL_NUMBER_DOUBLE) || (type2 == TCL_NUMBER_NAN)) { - result = TCL_ERROR; + if ((GetNumberFromObj(NULL, value2Ptr, &ptr2, &type2) != TCL_OK) + || (type2==TCL_NUMBER_DOUBLE) || (type2==TCL_NUMBER_NAN)) { TRACE(("%.20s %.20s => ILLEGAL 2nd TYPE %s\n", O2S(valuePtr), O2S(value2Ptr), (value2Ptr->typePtr? value2Ptr->typePtr->name : "null"))); + DECACHE_STACK_INFO(); IllegalExprOperandType(interp, pc, value2Ptr); - goto checkForCatch; - } - - /* 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: - /* TODO: const correctness ? */ - invalid = (mp_cmp_d((mp_int *)ptr2, 0) == MP_LT); - 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 = eePtr->constants[0]; - TRACE(("%s\n", O2S(objResultPtr))); - NEXT_INST_F(1, 2, 1); + CACHE_STACK_INFO(); + goto gotError; } - if (*pc == INST_LSHIFT) { - /* Large left shifts create integer overflow */ - result = Tcl_GetIntFromObj(NULL, value2Ptr, &shift); - if (result != TCL_OK) { - /* - * 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. - */ + /* + * Check for common, simple case. + */ - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "integer value too large to represent", -1)); - goto checkForCatch; - } - /* Handle shifts within the native long range */ - TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); - if ((type1 == TCL_NUMBER_LONG) && (shift < CHAR_BIT*sizeof(long)) - && (l = *((CONST long *)ptr1)) - && !(((l>0) ? l : ~l) - & -(1<<(CHAR_BIT*sizeof(long)-1-shift)))) { - TclNewLongObj(objResultPtr, (l<<shift)); - TRACE(("%s\n", O2S(objResultPtr))); - NEXT_INST_F(1, 2, 1); - } + if ((type1 == TCL_NUMBER_LONG) && (type2 == TCL_NUMBER_LONG)) { + l1 = *((const long *)ptr1); + l2 = *((const long *)ptr2); - /* Handle shifts within the native wide range */ - TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); - if ((type1 != TCL_NUMBER_BIG) - && (shift < CHAR_BIT*sizeof(Tcl_WideInt))) { - Tcl_WideInt w; + switch (*pc) { + case INST_MOD: + if (l2 == 0) { + TRACE(("%s %s => DIVIDE BY ZERO\n", O2S(valuePtr), + O2S(value2Ptr))); + goto divideByZero; + } else if ((l2 == 1) || (l2 == -1)) { + /* + * Div. by |1| always yields remainder of 0. + */ - 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 %s => ", O2S(valuePtr), O2S(value2Ptr))); + objResultPtr = TCONST(0); TRACE(("%s\n", O2S(objResultPtr))); NEXT_INST_F(1, 2, 1); - } - } - -/* - if ((type1 == TCL_NUMBER_LONG) && (shift < CHAR_BIT*sizeof(long)) - && (l = *((CONST long *)ptr1)) - && !(((l>0) ? l : ~l) - & -(1<<(CHAR_BIT*sizeof(long)-1-shift)))) { - TclNewLongObj(objResultPtr, (l<<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; + } else if (l1 == 0) { + /* + * 0 % (non-zero) always yields remainder of 0. + */ - switch (type1) { - case TCL_NUMBER_LONG: - zero = (*((CONST long *)ptr1) > (long)0); - break; -#ifndef NO_WIDE_TYPE - case TCL_NUMBER_WIDE: - zero = (*((CONST Tcl_WideInt *)ptr1) > (Tcl_WideInt)0); - break; -#endif - case TCL_NUMBER_BIG: - /* TODO: const correctness ? */ - zero = (mp_cmp_d((mp_int *)ptr1, 0) == MP_GT); - break; - default: - /* Unused, here to silence compiler warning. */ - zero = 0; - } - if (zero) { - objResultPtr = eePtr->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) { - long l = *((CONST long *)ptr1); - if (shift >= CHAR_BIT*sizeof(long)) { - if (l >= (long)0) { - objResultPtr = eePtr->constants[0]; - } else { - TclNewIntObj(objResultPtr, -1); - } - } else { - TclNewLongObj(objResultPtr, (l >> 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 (shift >= CHAR_BIT*sizeof(Tcl_WideInt)) { - if (w >= (Tcl_WideInt)0) { - objResultPtr = eePtr->constants[0]; - } else { - TclNewIntObj(objResultPtr, -1); - } + TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); + objResultPtr = TCONST(0); + TRACE(("%s\n", O2S(objResultPtr))); + NEXT_INST_F(1, 2, 1); } else { - objResultPtr = Tcl_NewWideIntObj(w >> shift); - } - TRACE(("%s\n", O2S(objResultPtr))); - NEXT_INST_F(1, 2, 1); - } -#endif - } - - { - mp_int big, bigResult, bigRemainder; - - if (Tcl_IsShared(valuePtr)) { - Tcl_GetBignumFromObj(NULL, valuePtr, &big); - } else { - Tcl_GetBignumAndClearObj(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); + lResult = l1 / l2; - 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 = *tosPtr; - Tcl_Obj *valuePtr = *(tosPtr - 1); - - 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"))); - IllegalExprOperandType(interp, pc, valuePtr); - 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"))); - IllegalExprOperandType(interp, pc, value2Ptr); - goto checkForCatch; - } - - if ((type1 == TCL_NUMBER_BIG) || (type2 == TCL_NUMBER_BIG)) { - mp_int big1, big2, bigResult; - mp_int *First, *Second; - int numPos; - - if (Tcl_IsShared(valuePtr)) { - Tcl_GetBignumFromObj(NULL, valuePtr, &big1); - } else { - Tcl_GetBignumAndClearObj(NULL, valuePtr, &big1); - } - if (Tcl_IsShared(value2Ptr)) { - Tcl_GetBignumFromObj(NULL, value2Ptr, &big2); - } else { - Tcl_GetBignumAndClearObj(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; + /* + * Force Tcl's integer division rules. + * TODO: examine for logic simplification + */ - 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; + if ((lResult < 0 || (lResult == 0 && + ((l1 < 0 && l2 > 0) || (l1 > 0 && l2 < 0)))) && + (lResult * l2 != l1)) { + lResult -= 1; + } + lResult = l1 - l2*lResult; + goto longResultOfArithmetic; } - 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 + case INST_RSHIFT: + if (l2 < 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", + NULL); + CACHE_STACK_INFO(); +#endif /* ERROR_CODE_FOR_EARLY_DETECTED_ARITH_ERROR */ + goto gotError; + } else if (l1 == 0) { + TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); + objResultPtr = TCONST(0); + TRACE(("%s\n", O2S(objResultPtr))); + NEXT_INST_F(1, 2, 1); + } else { + /* + * Quickly force large right shifts to 0 or -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; - break; - case INST_BITOR: - wResult = w1 | w2; - break; - case INST_BITXOR: - wResult = w1 ^ w2; - 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); - - 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))); - 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); - } - } - -#if 0 - case INST_MOD: - { - /* - * Only integers are allowed. We compute value op value2. - */ - - long i = 0, i2 = 0, rem, neg_divisor = 0; - long iResult = 0; /* Init. avoids compiler warning. */ - Tcl_WideInt w, w2, wResult = W0; - int doWide = 0; - Tcl_Obj *valuePtr, *value2Ptr; - - value2Ptr = *tosPtr; - valuePtr = *(tosPtr - 1); - if (valuePtr->typePtr == &tclIntType) { - i = valuePtr->internalRep.longValue; - } else if (valuePtr->typePtr == &tclWideIntType) { - TclGetWide(w,valuePtr); - } else { /* try to convert to int */ - REQUIRE_WIDE_OR_INT(result, valuePtr, i, w); - if (result != TCL_OK) { - TRACE(("%.20s %.20s => ILLEGAL 1st TYPE %s\n", - O2S(valuePtr), O2S(value2Ptr), - (valuePtr->typePtr? - valuePtr->typePtr->name : "null"))); - IllegalExprOperandType(interp, pc, valuePtr); - goto checkForCatch; - } - } - if (value2Ptr->typePtr == &tclIntType) { - i2 = value2Ptr->internalRep.longValue; - } else if (value2Ptr->typePtr == &tclWideIntType) { - TclGetWide(w2,value2Ptr); - } else { - REQUIRE_WIDE_OR_INT(result, value2Ptr, i2, w2); - if (result != TCL_OK) { - TRACE(("%.20s %.20s => ILLEGAL 2nd TYPE %s\n", - O2S(valuePtr), O2S(value2Ptr), - (value2Ptr->typePtr? - value2Ptr->typePtr->name : "null"))); - IllegalExprOperandType(interp, pc, value2Ptr); - goto checkForCatch; - } - } + if (l2 >= (long)(CHAR_BIT*sizeof(long))) { + /* + * We assume that INT_MAX is much larger than the + * number of bits in a long. This is a pretty safe + * assumption, given that the former is usually around + * 4e9 and the latter 32 or 64... + */ - do { - /* - * This code is tricky: C doesn't guarantee much about the - * quotient or remainder, and results with a negative divisor are - * not specified. Tcl guarantees that the remainder will have the - * same sign as the divisor and a smaller absolute value. - */ + TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); + if (l1 > 0L) { + objResultPtr = TCONST(0); + } else { + TclNewIntObj(objResultPtr, -1); + } + TRACE(("%s\n", O2S(objResultPtr))); + NEXT_INST_F(1, 2, 1); + } - if (value2Ptr->typePtr == &tclWideIntType && w2 == W0) { - if (valuePtr->typePtr == &tclIntType) { - TRACE(("%ld "LLD" => DIVIDE BY ZERO\n", i, w2)); - } else { - TRACE((LLD" "LLD" => DIVIDE BY ZERO\n", w, w2)); - } - goto divideByZero; - } - if (value2Ptr->typePtr == &tclIntType && i2 == 0) { - if (valuePtr->typePtr == &tclIntType) { - TRACE(("%ld %ld => DIVIDE BY ZERO\n", i, i2)); - } else { - TRACE((LLD" %ld => DIVIDE BY ZERO\n", w, i2)); - } - goto divideByZero; - } - if (valuePtr->typePtr == &tclWideIntType - || value2Ptr->typePtr == &tclWideIntType) { - Tcl_WideInt wRemainder; - /* - * Promote to wide - */ - if (valuePtr->typePtr == &tclIntType) { - w = Tcl_LongAsWide(i); - } else if (value2Ptr->typePtr == &tclIntType) { - w2 = Tcl_LongAsWide(i2); - } - if (w == LLONG_MIN && w2 == -1) { /* - * Integer overflow could happen with (LLONG_MIN % -1) - * even though it is not possible in the code below. + * Handle shifts within the native long range. */ - wRemainder = 0; - } else if (w == LLONG_MIN && w2 == LLONG_MAX) { - wRemainder = LLONG_MAX - 1; - } else if (w2 == LLONG_MIN) { + lResult = l1 >> ((int) l2); + goto longResultOfArithmetic; + } + + case INST_LSHIFT: + if (l2 < 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", + NULL); + CACHE_STACK_INFO(); +#endif /* ERROR_CODE_FOR_EARLY_DETECTED_ARITH_ERROR */ + goto gotError; + } else if (l1 == 0) { + TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); + objResultPtr = TCONST(0); + TRACE(("%s\n", O2S(objResultPtr))); + NEXT_INST_F(1, 2, 1); + } else if (l2 > (long) INT_MAX) { /* - * In C, a modulus operation is not well defined when the - * divisor is a negative number. So w % LLONG_MIN is not - * well defined in the code below because -LLONG_MIN is - * still a negative number. + * 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. */ - if (w == 0 || w == LLONG_MIN) { - wRemainder = 0; - } else if (w < 0) { - wRemainder = w; - } else { - wRemainder = LLONG_MIN + w; - } - neg_divisor = 1; + 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", NULL); + CACHE_STACK_INFO(); +#endif /* ERROR_CODE_FOR_EARLY_DETECTED_ARITH_ERROR */ + goto gotError; } else { - if (w2 < 0) { - w2 = -w2; - w = -w; /* Note: -LLONG_MIN == LLONG_MIN */ - neg_divisor = 1; - } - wRemainder = w % w2; + int shift = (int) l2; /* - * remainder is (remainder + divisor) when the remainder - * is negative. Watch out for the special case of a - * LLONG_MIN dividend and a negative divisor. Don't add - * the divisor in that case because the remainder should - * not be negative. + * Handle shifts within the native long range. */ - if (wRemainder < 0 && !(neg_divisor && (w == LLONG_MIN))) { - wRemainder += w2; + if ((size_t) shift < CHAR_BIT*sizeof(long) && (l1 != 0) + && !((l1>0 ? l1 : ~l1) & + -(1L<<(CHAR_BIT*sizeof(long) - 1 - shift)))) { + lResult = l1 << shift; + goto longResultOfArithmetic; } } - if ((neg_divisor && (wRemainder > 0)) || - (!neg_divisor && (wRemainder < 0))) { - wRemainder = -wRemainder; - } - wResult = wRemainder; - doWide = 1; - break; - } - - if (i == LONG_MIN && i2 == -1) { - /* - * Integer overflow could happen with (LONG_MIN % -1) even - * though it is not possible in the code below. - */ - rem = 0; - } else if (i == LONG_MIN && i2 == LONG_MAX) { - rem = LONG_MAX - 1; - } else if (i2 == LONG_MIN) { /* - * In C, a modulus operation is not well defined when the - * divisor is a negative number. So i % LONG_MIN is not well - * defined in the code below because -LONG_MIN is still a - * negative number. + * Too large; need to use the broken-out function. */ - if (i == 0 || i == LONG_MIN) { - rem = 0; - } else if (i < 0) { - rem = i; - } else { - rem = LONG_MIN + i; - } - neg_divisor = 1; - } else { - if (i2 < 0) { - i2 = -i2; - i = -i; /* Note: -LONG_MIN == LONG_MIN */ - neg_divisor = 1; - } - rem = i % i2; - - /* - * remainder is (remainder + divisor) when the remainder is - * negative. Watch out for the special case of a LONG_MIN - * dividend and a negative divisor. Don't add the divisor in - * that case because the remainder should not be negative. - */ + TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); + break; - if (rem < 0 && !(neg_divisor && (i == LONG_MIN))) { - rem += i2; + case INST_BITAND: + lResult = l1 & l2; + goto longResultOfArithmetic; + case INST_BITOR: + lResult = l1 | l2; + goto longResultOfArithmetic; + case INST_BITXOR: + lResult = l1 ^ l2; + longResultOfArithmetic: + TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); + if (Tcl_IsShared(valuePtr)) { + TclNewLongObj(objResultPtr, lResult); + TRACE(("%s\n", O2S(objResultPtr))); + NEXT_INST_F(1, 2, 1); } + TclSetLongObj(valuePtr, lResult); + TRACE(("%s\n", O2S(valuePtr))); + NEXT_INST_F(1, 1, 0); } - - if ((neg_divisor && (rem > 0)) || - (!neg_divisor && (rem < 0))) { - rem = -rem; - } - iResult = rem; - } while (0); + } /* - * Reuse the valuePtr object already on stack if possible. + * 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. */ - if (Tcl_IsShared(valuePtr)) { - if (doWide) { - TclNewWideIntObj(objResultPtr, wResult); - TRACE((LLD" "LLD" => "LLD"\n", w, w2, wResult)); - } else { - TclNewLongObj(objResultPtr, iResult); - TRACE(("%ld %ld => %ld\n", i, i2, iResult)); - } - NEXT_INST_F(1, 2, 1); - } else { /* reuse the valuePtr object */ - if (doWide) { - TRACE((LLD" "LLD" => "LLD"\n", w, w2, wResult)); - TclSetWideIntObj(valuePtr, wResult); - } else { - TRACE(("%ld %ld => %ld\n", i, i2, iResult)); - TclSetLongObj(valuePtr, iResult); - } + 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))); NEXT_INST_F(1, 1, 0); + } else { + TRACE_APPEND(("%s\n", O2S(objResultPtr))); + NEXT_INST_F(1, 2, 1); } - } -#endif + case INST_EXPON: case INST_ADD: case INST_SUB: case INST_DIV: - case INST_MULT: { - ClientData ptr1, ptr2; - int type1, type2; - Tcl_Obj *value2Ptr = *tosPtr; - Tcl_Obj *valuePtr = *(tosPtr - 1); + case INST_MULT: + value2Ptr = OBJ_AT_TOS; + valuePtr = OBJ_UNDER_TOS; - result = GetNumberFromObj(NULL, valuePtr, &ptr1, &type1); - if ((result != TCL_OK) -#ifndef ACCEPT_NAN - || (type1 == TCL_NUMBER_NAN) -#endif - ) { - result = TCL_ERROR; + if ((GetNumberFromObj(NULL, valuePtr, &ptr1, &type1) != TCL_OK) + || IsErroringNaNType(type1)) { TRACE(("%.20s %.20s => ILLEGAL 1st TYPE %s\n", O2S(value2Ptr), O2S(valuePtr), (valuePtr->typePtr? valuePtr->typePtr->name: "null"))); + DECACHE_STACK_INFO(); IllegalExprOperandType(interp, pc, valuePtr); - goto checkForCatch; + CACHE_STACK_INFO(); + goto gotError; } #ifdef ACCEPT_NAN if (type1 == TCL_NUMBER_NAN) { - /* NaN first argument -> result is also NaN */ + /* + * NaN first argument -> result is also NaN. + */ + NEXT_INST_F(1, 1, 0); } #endif - result = GetNumberFromObj(NULL, value2Ptr, &ptr2, &type2); - if ((result != TCL_OK) -#ifndef ACCEPT_NAN - || (type2 == TCL_NUMBER_NAN) -#endif - ) { - result = TCL_ERROR; + if ((GetNumberFromObj(NULL, value2Ptr, &ptr2, &type2) != TCL_OK) + || IsErroringNaNType(type2)) { TRACE(("%.20s %.20s => ILLEGAL 2nd TYPE %s\n", O2S(value2Ptr), O2S(valuePtr), (value2Ptr->typePtr? value2Ptr->typePtr->name: "null"))); + DECACHE_STACK_INFO(); IllegalExprOperandType(interp, pc, value2Ptr); - goto checkForCatch; + CACHE_STACK_INFO(); + goto gotError; } #ifdef ACCEPT_NAN if (type2 == TCL_NUMBER_NAN) { - /* NaN second argument -> result is also NaN */ + /* + * NaN second argument -> result is also NaN. + */ + objResultPtr = value2Ptr; NEXT_INST_F(1, 2, 1); } #endif - if ((type1 == TCL_NUMBER_DOUBLE) || (type2 == TCL_NUMBER_DOUBLE)) { - /* At least one of the values is floating-point, so perform - * floating point calculations */ - double d1, d2, dResult; - Tcl_GetDoubleFromObj(NULL, valuePtr, &d1); - Tcl_GetDoubleFromObj(NULL, value2Ptr, &d2); + /* + * Handle (long,long) arithmetic as best we can without going out to + * an external function. + */ + + if ((type1 == TCL_NUMBER_LONG) && (type2 == TCL_NUMBER_LONG)) { + Tcl_WideInt w1, w2, wResult; + + l1 = *((const long *)ptr1); + l2 = *((const long *)ptr2); switch (*pc) { 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) { - TRACE(("%.6g %.6g => DIVIDE BY ZERO\n", d1, d2)); - goto divideByZero; - } -#endif + w1 = (Tcl_WideInt) l1; + w2 = (Tcl_WideInt) l2; + wResult = w1 + w2; +#ifdef TCL_WIDE_INT_IS_LONG /* - * 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. + * Check for overflow. */ - dResult = d1 / d2; - break; - default: - /* Unused, here to silence compiler warning. */ - dResult = 0; - } - -#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))); - TclExprFloatError(interp, dResult); - result = TCL_ERROR; - goto checkForCatch; - } + if (Overflowing(w1, w2, wResult)) { + goto overflow; + } #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); - } + goto wideResultOfArithmetic; - 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; + case INST_SUB: + w1 = (Tcl_WideInt) l1; + w2 = (Tcl_WideInt) l2; + wResult = w1 - w2; +#ifdef TCL_WIDE_INT_IS_LONG + /* + * Must check for overflow. The macro tests for overflows in + * sums by looking at the sign bits. As we have a subtraction + * here, we are adding -w2. As -w2 could in turn overflow, we + * test with ~w2 instead: it has the opposite sign bit to w2 + * so it does the job. Note that the only "bad" case (w2==0) + * is irrelevant for this macro, as in that case w1 and + * wResult have the same sign and there is no overflow anyway. + */ + if (Overflowing(w1, ~w2, wResult)) { + goto overflow; + } +#endif + wideResultOfArithmetic: TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); if (Tcl_IsShared(valuePtr)) { - TclNewLongObj(objResultPtr,lResult); + objResultPtr = Tcl_NewWideIntObj(wResult); TRACE(("%s\n", O2S(objResultPtr))); NEXT_INST_F(1, 2, 1); } - TclSetLongObj(valuePtr, lResult); + Tcl_SetWideIntObj(valuePtr, wResult); TRACE(("%s\n", O2S(valuePtr))); NEXT_INST_F(1, 1, 0); - } - } - - 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); - } - - 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 (((w1 < 0) && (w2 < 0) && (wResult > 0)) - || ((w1 > 0) && (w2 > 0) && (wResult < 0))) { - 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 */ - if (((w1 < 0) && (w2 > 0) && (wResult > 0)) - || ((w1 > 0) && (w2 < 0) && (wResult < 0))) { - goto overflow; - } - } - break; case INST_DIV: - if (w2 == 0) { + if (l2 == 0) { TRACE(("%s %s => DIVIDE BY ZERO\n", O2S(valuePtr), O2S(value2Ptr))); goto divideByZero; - } + } else if ((l1 == LONG_MIN) && (l2 == -1)) { + /* + * Can't represent (-LONG_MIN) as a long. + */ - /* Need a bignum to represent (LLONG_MIN / -1) */ - if ((w1 == LLONG_MIN) && (w2 == -1)) { goto overflow; } - 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; - } - - 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); - } + lResult = l1 / l2; - overflow: - { - mp_int big1, big2, bigResult, bigRemainder; - TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); - if (Tcl_IsShared(valuePtr)) { - Tcl_GetBignumFromObj(NULL, valuePtr, &big1); - } else { - Tcl_GetBignumAndClearObj(NULL, valuePtr, &big1); - } - if (Tcl_IsShared(value2Ptr)) { - Tcl_GetBignumFromObj(NULL, value2Ptr, &big2); - } else { - Tcl_GetBignumAndClearObj(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); - 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); - } - if (*pc == INST_MOD) { - mp_copy(&bigRemainder, &bigResult); - } - mp_clear(&bigRemainder); - 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); - } - } - - case INST_MOD: - case INST_EXPON: { - /* - * Operands must be numeric and ints get converted to floats if - * necessary. We compute value op value2. - */ - - double d1, d2; - double dResult = 0.0; /* Init. avoids compiler warning. */ - Tcl_Obj *valuePtr,*value2Ptr; -#if 0 - Tcl_ObjType *t1Ptr, *t2Ptr; - long i = 0, i2 = 0, quot; /* Init. avoids compiler warning. */ - long iResult = 0; /* Init. avoids compiler warning. */ - int doDouble = 0; /* 1 if doing floating arithmetic */ - Tcl_WideInt w, w2, wquot; - Tcl_WideInt wResult = W0; /* Init. avoids compiler warning. */ - int doWide = 0; /* 1 if doing wide arithmetic. */ - int length; - - value2Ptr = *tosPtr; - valuePtr = *(tosPtr - 1); - t1Ptr = valuePtr->typePtr; - t2Ptr = value2Ptr->typePtr; - - if (t1Ptr == &tclIntType) { - i = valuePtr->internalRep.longValue; - } else if (t1Ptr == &tclWideIntType) { - TclGetWide(w,valuePtr); - } else if ((t1Ptr == &tclDoubleType) && (valuePtr->bytes == NULL)) { - /* - * We can only use the internal rep directly if there is no string - * rep. Otherwise the string rep might actually look like an - * integer, which is preferred. - */ - - d1 = valuePtr->internalRep.doubleValue; - } else { - char *s = Tcl_GetStringFromObj(valuePtr, &length); - if (TclLooksLikeInt(s, length)) { - GET_WIDE_OR_INT(result, valuePtr, i, w); - } else { - result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL, - valuePtr, &d1); - } - if (result != TCL_OK) { - TRACE(("%.20s %.20s => ILLEGAL 1st TYPE %s\n", - s, O2S(valuePtr), - (valuePtr->typePtr? valuePtr->typePtr->name: "null"))); - IllegalExprOperandType(interp, pc, valuePtr); - goto checkForCatch; - } - t1Ptr = valuePtr->typePtr; - } - - if (t2Ptr == &tclIntType) { - i2 = value2Ptr->internalRep.longValue; - } else if (t2Ptr == &tclWideIntType) { - TclGetWide(w2,value2Ptr); - } else if ((t2Ptr == &tclDoubleType) && (value2Ptr->bytes == NULL)) { - /* - * We can only use the internal rep directly if there is no string - * rep. Otherwise the string rep might actually look like an - * integer, which is preferred. - */ - - d2 = value2Ptr->internalRep.doubleValue; - } else { - char *s = Tcl_GetStringFromObj(value2Ptr, &length); - if (TclLooksLikeInt(s, length)) { - GET_WIDE_OR_INT(result, value2Ptr, i2, w2); - } else { - result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL, - value2Ptr, &d2); - } - if (result != TCL_OK) { - TRACE(("%.20s %.20s => ILLEGAL 2nd TYPE %s\n", - O2S(value2Ptr), s, - (value2Ptr->typePtr? - value2Ptr->typePtr->name : "null"))); - IllegalExprOperandType(interp, pc, value2Ptr); - goto checkForCatch; - } - t2Ptr = value2Ptr->typePtr; - } - - if ((t1Ptr == &tclDoubleType) || (t2Ptr == &tclDoubleType)) { - /* - * Do double arithmetic. - */ - doDouble = 1; - if (t1Ptr == &tclIntType) { - d1 = i; /* promote value 1 to double */ - } else if (t2Ptr == &tclIntType) { - d2 = i2; /* promote value 2 to double */ - } else if (t1Ptr == &tclWideIntType) { - d1 = Tcl_WideAsDouble(w); - } else if (t2Ptr == &tclWideIntType) { - d2 = Tcl_WideAsDouble(w2); - } - switch (*pc) { - case INST_ADD: - dResult = d1 + d2; - break; - case INST_SUB: - dResult = d1 - d2; - break; - case INST_MULT: - 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; - } - dResult = pow(d1, d2); - break; - } - - /* - * Check now for IEEE floating-point error. - */ - - if (IS_NAN(dResult)) { - TRACE(("%.20s %.20s => IEEE FLOATING PT ERROR\n", - O2S(valuePtr), O2S(value2Ptr))); - TclExprFloatError(interp, dResult); - result = TCL_ERROR; - goto checkForCatch; - } - } else if ((t1Ptr == &tclWideIntType) || (t2Ptr == &tclWideIntType)) { - /* - * Do wide integer arithmetic. - */ - doWide = 1; - if (t1Ptr == &tclIntType) { - w = Tcl_LongAsWide(i); - } else if (t2Ptr == &tclIntType) { - w2 = Tcl_LongAsWide(i2); - } - switch (*pc) { - case INST_ADD: - wResult = w + w2; - break; - case INST_SUB: - wResult = w - w2; - break; - case INST_MULT: - wResult = w * w2; - break; - case INST_DIV: /* - * When performing integer division, protect against integer - * overflow. Round towards zero when the quotient is positive, - * otherwise round towards -Infinity. + * Force Tcl's integer division rules. + * TODO: examine for logic simplification */ - if (w2 == W0) { - TRACE((LLD" "LLD" => DIVIDE BY ZERO\n", w, w2)); - goto divideByZero; - } - if (w == LLONG_MIN && w2 == -1) { - /* Avoid integer overflow on (LLONG_MIN / -1) */ - wquot = LLONG_MIN; - } else { - wquot = w / w2; - /* - * Round down to a smaller negative number if there is a - * remainder and the quotient is negative or zero and the - * signs don't match. Note that we don't use a modulus to - * find the remainder since it is not well defined in C - * when the divisor is negative. - */ - if (((wquot < 0) || ((wquot == 0) && - ((w < 0 && w2 > 0) || (w > 0 && w2 < 0)))) && - ((wquot * w2) != w)) { - wquot -= 1; - } - } - wResult = wquot; - break; - case INST_EXPON: { - int errExpon; - wResult = ExponWide(w, w2, &errExpon); - if (errExpon) { - TRACE((LLD" "LLD" => EXPONENT OF ZERO\n", w, w2)); - goto exponOfZero; + if (((lResult < 0) || ((lResult == 0) && + ((l1 < 0 && l2 > 0) || (l1 > 0 && l2 < 0)))) && + ((lResult * l2) != l1)) { + lResult -= 1; } - break; - } - } - } else { - /* - * Do integer arithmetic. - */ - switch (*pc) { - case INST_ADD: - iResult = i + i2; - break; - case INST_SUB: - iResult = i - i2; - break; - case INST_MULT: - iResult = i * i2; - break; - case INST_DIV: - /* - * When performing integer division, protect against integer - * overflow. Round towards zero when the quotient is positive, - * otherwise round towards -Infinity. - */ - if (i2 == 0) { - TRACE(("%ld %ld => DIVIDE BY ZERO\n", i, i2)); - goto divideByZero; - } - if (i == LONG_MIN && i2 == -1) { - /* Avoid integer overflow on (LONG_MIN / -1) */ - quot = LONG_MIN; - } else { - quot = i / i2; - /* - * Round down to a smaller negative number if there is a - * remainder and the quotient is negative or zero and the - * signs don't match. Note that we don't use a modulus to - * find the remainder since it is not well defined in C - * when the divisor is negative. - */ - if (((quot < 0) || ((quot == 0) && - ((i<0 && i2>0) || (i>0 && i2<0)))) && - ((quot * i2) != i)) { - quot -= 1; - } - } - iResult = quot; - break; - case INST_EXPON: { - int errExpon; + goto longResultOfArithmetic; - iResult = ExponLong(i, i2, &errExpon); - if (errExpon) { - TRACE(("%ld %ld => EXPONENT OF ZERO\n", i, i2)); - goto exponOfZero; + case INST_MULT: + if (((sizeof(long) >= 2*sizeof(int)) + && (l1 <= INT_MAX) && (l1 >= INT_MIN) + && (l2 <= INT_MAX) && (l2 >= INT_MIN)) + || ((sizeof(long) >= 2*sizeof(short)) + && (l1 <= SHRT_MAX) && (l1 >= SHRT_MIN) + && (l2 <= SHRT_MAX) && (l2 >= SHRT_MIN))) { + lResult = l1 * l2; + goto longResultOfArithmetic; } - break; } - } - } - - /* - * Reuse the valuePtr object already on stack if possible. - */ - if (Tcl_IsShared(valuePtr)) { - if (doDouble) { - TclNewDoubleObj(objResultPtr, dResult); - TRACE(("%.6g %.6g => %.6g\n", d1, d2, dResult)); - } else if (doWide) { - TclNewWideIntObj(objResultPtr, wResult); - TRACE((LLD" "LLD" => "LLD"\n", w, w2, wResult)); - } else { - TclNewLongObj(objResultPtr, iResult); - TRACE(("%ld %ld => %ld\n", i, i2, iResult)); - } - NEXT_INST_F(1, 2, 1); - } else { /* reuse the valuePtr object */ - if (doDouble) { /* NB: stack top is off by 1 */ - TRACE(("%.6g %.6g => %.6g\n", d1, d2, dResult)); - TclSetDoubleObj(valuePtr, dResult); - } else if (doWide) { - TRACE((LLD" "LLD" => "LLD"\n", w, w2, wResult)); - TclSetWideIntObj(valuePtr, wResult); - } else { - TRACE(("%ld %ld => %ld\n", i, i2, iResult)); - TclSetLongObj(valuePtr, iResult); - } - NEXT_INST_F(1, 1, 0); - } -#else - value2Ptr = *tosPtr; - valuePtr = *(tosPtr - 1); - result = Tcl_GetDoubleFromObj(NULL, valuePtr, &d1); - if (result != TCL_OK) { -#ifdef ACCEPT_NAN - if (valuePtr->typePtr == &tclDoubleType) { - /* NaN first argument -> result is also NaN */ - result = TCL_OK; - NEXT_INST_F(1, 1, 0); - } -#endif - TRACE(("%.20s %.20s => ILLEGAL 1st TYPE %s\n", - O2S(value2Ptr), O2S(valuePtr), - (valuePtr->typePtr? valuePtr->typePtr->name: "null"))); - IllegalExprOperandType(interp, pc, valuePtr); - goto checkForCatch; - } - result = Tcl_GetDoubleFromObj(NULL, value2Ptr, &d2); - if (result != TCL_OK) { -#ifdef ACCEPT_NAN - if (value2Ptr->typePtr == &tclDoubleType) { - /* NaN second argument -> result is also NaN */ - objResultPtr = value2Ptr; - result = TCL_OK; - NEXT_INST_F(1, 2, 1); - } -#endif - TRACE(("%.20s %.20s => ILLEGAL 2nd TYPE %s\n", - O2S(value2Ptr), O2S(valuePtr), - (value2Ptr->typePtr? value2Ptr->typePtr->name: "null"))); - IllegalExprOperandType(interp, pc, value2Ptr); - goto checkForCatch; - } - if (valuePtr->typePtr == &tclDoubleType - || value2Ptr->typePtr == &tclDoubleType) { - /* At least one of the values is floating-point, so perform - * floating point calculations */ - switch (*pc) { - case INST_EXPON: - if (d1==0.0 && d2<0.0) { - TRACE(("%.6g %.6g => EXPONENT OF ZERO\n", d1, d2)); - goto exponOfZero; - } - dResult = pow(d1, d2); - break; - case INST_MOD: - if (valuePtr->typePtr == &tclDoubleType) { - TRACE(("%.20s %.20s => ILLEGAL 1st TYPE %s\n", - O2S(value2Ptr), O2S(valuePtr), (valuePtr->typePtr? - valuePtr->typePtr->name: "null"))); - IllegalExprOperandType(interp, pc, valuePtr); - } else { - TRACE(("%.20s %.20s => ILLEGAL 2nd TYPE %s\n", - O2S(value2Ptr), O2S(valuePtr), (value2Ptr->typePtr? - value2Ptr->typePtr->name: "null"))); - IllegalExprOperandType(interp, pc, value2Ptr); - } - result = TCL_ERROR; - goto checkForCatch; - } -#ifndef ACCEPT_NAN /* - * Check now for IEEE floating-point error. + * Fall through with INST_EXPON, INST_DIV and large multiplies. */ + } - if (TclIsNaN(dResult)) { - TRACE(("%.20s %.20s => IEEE FLOATING PT ERROR\n", - O2S(valuePtr), O2S(value2Ptr))); - TclExprFloatError(interp, dResult); - result = TCL_ERROR; - goto checkForCatch; - } -#endif - if (Tcl_IsShared(valuePtr)) { - TclNewDoubleObj(objResultPtr, dResult); - NEXT_INST_F(1, 2, 1); - } - TclSetDoubleObj(valuePtr, dResult); + 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 == NULL) { + TRACE_APPEND(("%s\n", O2S(valuePtr))); NEXT_INST_F(1, 1, 0); } else { - /* Both values are some kind of integer */ - /* TODO: optimize use of narrower native integers */ - mp_int big1, big2, bigResult, bigRemainder; - - Tcl_GetBignumFromObj(NULL, valuePtr, &big1); - Tcl_GetBignumFromObj(NULL, value2Ptr, &big2); - mp_init(&bigResult); - switch (*pc) { - case INST_MOD: - if (mp_iszero(&big2)) { - TRACE(("%s %s => DIVIDE BY ZERO\n", O2S(valuePtr), - O2S(value2Ptr))); - mp_clear(&big1); - mp_clear(&big2); - goto divideByZero; - } - mp_init(&bigRemainder); - mp_div(&big1, &big2, &bigResult, &bigRemainder); - if (!mp_iszero(&bigRemainder) - && (bigRemainder.sign != big2.sign)) { - /* Convert to Tcl's integer division rules */ - mp_sub_d(&bigResult, 1, &bigResult); - mp_add(&bigRemainder, &big2, &bigRemainder); - } - if (*pc == INST_MOD) { - mp_copy(&bigRemainder, &bigResult); - } - mp_clear(&bigRemainder); - break; - case INST_EXPON: - if (mp_iszero(&big2)) { - /* Anything to the zero power is 1 */ - mp_clear(&big1); - mp_clear(&big2); - objResultPtr = eePtr->constants[1]; - NEXT_INST_F(1, 2, 1); - } - if (mp_iszero(&big1)) { - if (mp_cmp_d(&big2, 0) == MP_LT) { - TRACE(("%s %s => EXPONENT OF ZERO\n", O2S(valuePtr), - O2S(value2Ptr))); - mp_clear(&big1); - mp_clear(&big2); - goto exponOfZero; - } - mp_clear(&big1); - mp_clear(&big2); - objResultPtr = eePtr->constants[0]; - NEXT_INST_F(1, 2, 1); - } - if (mp_cmp_d(&big2, 0) == MP_LT) { - switch (mp_cmp_d(&big1, 1)) { - case MP_GT: - objResultPtr = eePtr->constants[0]; - break; - case MP_EQ: - objResultPtr = eePtr->constants[1]; - break; - case MP_LT: - mp_add_d(&big1, 1, &big1); - if (mp_cmp_d(&big1, 0) == MP_LT) { - objResultPtr = eePtr->constants[0]; - break; - } - mp_mod_2d(&big2, 1, &big2); - if (mp_iszero(&big2)) { - objResultPtr = eePtr->constants[1]; - } else { - TclNewIntObj(objResultPtr, -1); - } - } - mp_clear(&big1); - mp_clear(&big2); - NEXT_INST_F(1, 2, 1); - } - if (big2.used > 1) { - Tcl_SetObjResult(interp, - Tcl_NewStringObj("exponent too large", -1)); - mp_clear(&big1); - mp_clear(&big2); - goto checkForCatch; - } - mp_expt_d(&big1, big2.dp[0], &bigResult); - 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); + TRACE_APPEND(("%s\n", O2S(objResultPtr))); + NEXT_INST_F(1, 2, 1); } -#endif - } case INST_LNOT: { int b; - Tcl_Obj *valuePtr = *tosPtr; + + valuePtr = OBJ_AT_TOS; /* TODO - check claim that taking address of b harms performance */ - /* TODO - consider optimization search for eePtr->constants */ - result = TclGetBooleanFromObj(NULL, valuePtr, &b); - if (result != TCL_OK) { - TRACE(("\"%.20s\" => ILLEGAL TYPE %s\n", O2S(valuePtr), + /* TODO - consider optimization search for constants */ + if (TclGetBooleanFromObj(NULL, valuePtr, &b) != TCL_OK) { + TRACE(("\"%.20s\" => ERROR: illegal type %s\n", O2S(valuePtr), (valuePtr->typePtr? valuePtr->typePtr->name : "null"))); + DECACHE_STACK_INFO(); IllegalExprOperandType(interp, pc, valuePtr); - goto checkForCatch; + CACHE_STACK_INFO(); + goto gotError; } /* TODO: Consider peephole opt. */ - objResultPtr = eePtr->constants[!b]; + objResultPtr = TCONST(!b); + TRACE_WITH_OBJ(("%s => ", O2S(valuePtr)), objResultPtr); NEXT_INST_F(1, 1, 1); } - case INST_BITNOT: { - mp_int big; - ClientData ptr; - int type; - Tcl_Obj *valuePtr = *tosPtr; + 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)) { + /* + * ... ~$NonInteger => raise an error. + */ - result = GetNumberFromObj(NULL, valuePtr, &ptr, &type); - if ((result != TCL_OK) - || (type == TCL_NUMBER_NAN) || (type == TCL_NUMBER_DOUBLE)) { - /* ... ~$NonInteger => raise an error */ - result = TCL_ERROR; - TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(valuePtr), + TRACE_APPEND(("ERROR: illegal type %s\n", (valuePtr->typePtr? valuePtr->typePtr->name : "null"))); + DECACHE_STACK_INFO(); IllegalExprOperandType(interp, pc, valuePtr); - goto checkForCatch; - } - if (type == TCL_NUMBER_LONG) { - long l = *((CONST long *)ptr); - if (Tcl_IsShared(valuePtr)) { - TclNewLongObj(objResultPtr, ~l); - NEXT_INST_F(1, 1, 1); - } - TclSetLongObj(valuePtr, ~l); - NEXT_INST_F(1, 0, 0); + CACHE_STACK_INFO(); + goto gotError; } -#ifndef NO_WIDE_TYPE - if (type == TCL_NUMBER_LONG) { - Tcl_WideInt w = *((CONST Tcl_WideInt *)ptr); + if (type1 == TCL_NUMBER_LONG) { + l1 = *((const long *) ptr1); if (Tcl_IsShared(valuePtr)) { - objResultPtr = Tcl_NewWideIntObj(~w); + TclNewLongObj(objResultPtr, ~l1); + TRACE_APPEND(("%s\n", O2S(objResultPtr))); NEXT_INST_F(1, 1, 1); } - Tcl_SetWideIntObj(valuePtr, ~w); + TclSetLongObj(valuePtr, ~l1); + TRACE_APPEND(("%s\n", O2S(valuePtr))); NEXT_INST_F(1, 0, 0); } -#endif - if (Tcl_IsShared(valuePtr)) { - Tcl_GetBignumFromObj(NULL, valuePtr, &big); - } else { - Tcl_GetBignumAndClearObj(NULL, valuePtr, &big); - } - /* ~a = - a - 1 */ - mp_neg(&big, &big); - mp_sub_d(&big, 1, &big); - if (Tcl_IsShared(valuePtr)) { - objResultPtr = Tcl_NewBignumObj(&big); + 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))); + NEXT_INST_F(1, 0, 0); } - Tcl_SetBignumObj(valuePtr, &big); - NEXT_INST_F(1, 0, 0); - } - - case INST_UMINUS: { - ClientData ptr; - int type; - Tcl_Obj *valuePtr = *tosPtr; - 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), + 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", (valuePtr->typePtr? valuePtr->typePtr->name : "null"))); + DECACHE_STACK_INFO(); IllegalExprOperandType(interp, pc, valuePtr); - goto checkForCatch; + CACHE_STACK_INFO(); + goto gotError; } - 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); + switch (type1) { + case TCL_NUMBER_NAN: + /* -NaN => NaN */ + TRACE_APPEND(("%s\n", O2S(valuePtr))); NEXT_INST_F(1, 0, 0); - } - case TCL_NUMBER_LONG: { - long l = *((CONST long *)ptr); - if (l != LONG_MIN) { - if (Tcl_IsShared(valuePtr)) { - TclNewLongObj(objResultPtr, -l); - NEXT_INST_F(1, 1, 1); - } - TclSetLongObj(valuePtr, -l); - NEXT_INST_F(1, 0, 0); - } - /* FALLTHROUGH */ - } -#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) { + case TCL_NUMBER_LONG: + l1 = *((const long *) ptr1); + if (l1 != LONG_MIN) { if (Tcl_IsShared(valuePtr)) { - objResultPtr = Tcl_NewWideIntObj(-w); + TclNewLongObj(objResultPtr, -l1); + TRACE_APPEND(("%s\n", O2S(objResultPtr))); NEXT_INST_F(1, 1, 1); } - Tcl_SetWideIntObj(valuePtr, -w); + TclSetLongObj(valuePtr, -l1); + TRACE_APPEND(("%s\n", O2S(valuePtr))); 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: - if (Tcl_IsShared(valuePtr)) { - Tcl_GetBignumFromObj(NULL, valuePtr, &big); - } else { - Tcl_GetBignumAndClearObj(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 */ + 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))); NEXT_INST_F(1, 0, 0); } - } - - case INST_CALL_BUILTIN_FUNC1: { - Tcl_Panic("TclExecuteByteCode: obsolete INST_CALL_BUILTIN_FUNC1 found"); - } - - case INST_CALL_FUNC1: { - Tcl_Panic("TclExecuteByteCode: obsolete INST_CALL_FUNC1 found"); - } 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. + * 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. */ - ClientData ptr; - int type; - Tcl_Obj *valuePtr = *tosPtr; + valuePtr = OBJ_AT_TOS; + TRACE(("\"%.20s\" => ", O2S(valuePtr))); - if (GetNumberFromObj(NULL, valuePtr, &ptr, &type) != TCL_OK) { + if (GetNumberFromObj(NULL, valuePtr, &ptr1, &type1) != TCL_OK) { if (*pc == INST_UPLUS) { - /* ... +$NonNumeric => raise an error */ - result = TCL_ERROR; - TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(valuePtr), - (valuePtr->typePtr? valuePtr->typePtr->name : "null"))); + /* + * ... +$NonNumeric => raise an error. + */ + + TRACE_APPEND(("ERROR: illegal type %s\n", + (valuePtr->typePtr? valuePtr->typePtr->name:"null"))); + DECACHE_STACK_INFO(); IllegalExprOperandType(interp, pc, valuePtr); - goto checkForCatch; - } else { - /* ... TryConvertToNumeric($NonNumeric) is acceptable */ - TRACE(("\"%.20s\" => not numeric\n", O2S(valuePtr))); - NEXT_INST_F(1, 0, 0); + CACHE_STACK_INFO(); + goto gotError; } + + /* ... TryConvertToNumeric($NonNumeric) is acceptable */ + TRACE_APPEND(("not numeric\n")); + NEXT_INST_F(1, 0, 0); } -#ifndef ACCEPT_NAN - if (type == TCL_NUMBER_NAN) { - result = TCL_ERROR; + if (IsErroringNaNType(type1)) { if (*pc == INST_UPLUS) { - /* ... +$NonNumeric => raise an error */ - TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(valuePtr), - (valuePtr->typePtr? valuePtr->typePtr->name : "null"))); + /* + * ... +$NonNumeric => raise an error. + */ + + TRACE_APPEND(("ERROR: illegal type %s\n", + (valuePtr->typePtr? valuePtr->typePtr->name:"null"))); + DECACHE_STACK_INFO(); IllegalExprOperandType(interp, pc, valuePtr); + CACHE_STACK_INFO(); } else { - /* Numeric conversion of NaN -> error */ - TRACE(("\"%.20s\" => IEEE FLOATING PT ERROR\n", - O2S(objResultPtr))); - TclExprFloatError(interp, *((CONST double *)ptr)); + /* + * Numeric conversion of NaN -> error. + */ + + TRACE_APPEND(("ERROR: IEEE floating pt error\n")); + DECACHE_STACK_INFO(); + TclExprFloatError(interp, *((const double *) ptr1)); + CACHE_STACK_INFO(); } - goto checkForCatch; + goto gotError; } -#endif /* - * Ensure that the numeric value has a string rep the same as - * the formatted version of its internal rep. This is used, e.g., - * to make sure that "expr {0001}" yields "1", not "0001". - * We implement this by _discarding_ the string rep since we - * know it will be regenerated, if needed later, by formatting - * the internal rep's value. + * Ensure that the numeric value has a string rep the same as the + * formatted version of its internal rep. This is used, e.g., to make + * sure that "expr {0001}" yields "1", not "0001". We implement this + * by _discarding_ the string rep since we know it will be + * regenerated, if needed later, by formatting the internal rep's + * value. */ + if (valuePtr->bytes == NULL) { - TRACE(("\"%.20s\" => numeric, same Tcl_Obj\n", O2S(valuePtr))); + TRACE_APPEND(("numeric, same Tcl_Obj\n")); 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 intrep, but not the string, so we - * temporarily hide the string so we do not copy it. + * Here we do some surgery within the Tcl_Obj internals. We want + * to copy the intrep, but not the string, so we temporarily hide + * the string so we do not copy it. */ + char *savedString = valuePtr->bytes; + valuePtr->bytes = NULL; objResultPtr = Tcl_DuplicateObj(valuePtr); valuePtr->bytes = savedString; - TRACE(("\"%.20s\" => numeric, new Tcl_Obj\n", O2S(valuePtr))); + TRACE_APPEND(("numeric, new Tcl_Obj\n")); NEXT_INST_F(1, 1, 1); } TclInvalidateStringRep(valuePtr); - TRACE(("\"%.20s\" => numeric, same Tcl_Obj\n", O2S(valuePtr))); + TRACE_APPEND(("numeric, same Tcl_Obj\n")); NEXT_INST_F(1, 0, 0); } + /* + * End of numeric operator instructions. + * ----------------------------------------------------------------- + */ + + case INST_TRY_CVT_TO_BOOLEAN: + valuePtr = OBJ_AT_TOS; + if (valuePtr->typePtr == &tclBooleanType) { + objResultPtr = TCONST(1); + } else { + int result = (TclSetBooleanFromAny(NULL, valuePtr) == TCL_OK); + objResultPtr = TCONST(result); + } + TRACE_WITH_OBJ(("\"%.30s\" => ", O2S(valuePtr)), objResultPtr); + NEXT_INST_F(1, 0, 1); + case INST_BREAK: + /* DECACHE_STACK_INFO(); Tcl_ResetResult(interp); CACHE_STACK_INFO(); + */ result = TCL_BREAK; cleanup = 0; + TRACE(("=> BREAK!\n")); goto processExceptionReturn; case INST_CONTINUE: + /* DECACHE_STACK_INFO(); Tcl_ResetResult(interp); CACHE_STACK_INFO(); + */ result = TCL_CONTINUE; cleanup = 0; + TRACE(("=> CONTINUE!\n")); goto processExceptionReturn; - case INST_FOREACH_START4: { + { + ForeachInfo *infoPtr; + Var *iterVarPtr, *listVarPtr; + Tcl_Obj *oldValuePtr, *listPtr, **elements; + ForeachVarList *varListPtr; + int numLists, iterNum, listTmpIndex, listLen, numVars; + int varIndex, valIndex, continueLoop, j, iterTmpIndex; + long i; + + case INST_FOREACH_START4: /* DEPRECATED */ /* * Initialize the temporary local var that holds the count of the * number of iterations of the loop body to -1. */ - int opnd; - ForeachInfo *infoPtr; - int iterTmpIndex; - Var *iterVarPtr; - Tcl_Obj *oldValuePtr; - opnd = TclGetUInt4AtPtr(pc+1); - infoPtr = (ForeachInfo *) codePtr->auxDataArrayPtr[opnd].clientData; + infoPtr = codePtr->auxDataArrayPtr[opnd].clientData; iterTmpIndex = infoPtr->loopCtTemp; - iterVarPtr = &(compiledLocals[iterTmpIndex]); + iterVarPtr = LOCAL(iterTmpIndex); oldValuePtr = iterVarPtr->value.objPtr; if (oldValuePtr == NULL) { @@ -5434,8 +6766,6 @@ TclExecuteByteCode( } else { TclSetLongObj(oldValuePtr, -1); } - TclSetVarScalar(iterVarPtr); - TclClearVarUndefined(iterVarPtr); TRACE(("%u => loop iter count temp %d\n", opnd, iterTmpIndex)); #ifndef TCL_COMPILE_DEBUG @@ -5446,41 +6776,29 @@ TclExecuteByteCode( */ pc += 5; + TCL_DTRACE_INST_NEXT(); #else NEXT_INST_F(5, 0, 0); #endif - } - case INST_FOREACH_STEP4: { + case INST_FOREACH_STEP4: /* DEPRECATED */ /* * "Step" a foreach loop (i.e., begin its next iteration) by assigning * the next value list element to each loop var. */ - int opnd; - ForeachInfo *infoPtr; - ForeachVarList *varListPtr; - int numLists; - Tcl_Obj *listPtr,*valuePtr, *value2Ptr; - Tcl_Obj **elements; - Var *iterVarPtr, *listVarPtr; - int iterNum, listTmpIndex, listLen, numVars; - int varIndex, valIndex, continueLoop, j; - long i; - Var *varPtr; - char *part1; - opnd = TclGetUInt4AtPtr(pc+1); - infoPtr = (ForeachInfo *) codePtr->auxDataArrayPtr[opnd].clientData; + TRACE(("%u => ", opnd)); + infoPtr = codePtr->auxDataArrayPtr[opnd].clientData; numLists = infoPtr->numLists; /* * Increment the temp holding the loop iteration number. */ - iterVarPtr = &(compiledLocals[infoPtr->loopCtTemp]); + iterVarPtr = LOCAL(infoPtr->loopCtTemp); valuePtr = iterVarPtr->value.objPtr; - iterNum = (valuePtr->internalRep.longValue + 1); + iterNum = valuePtr->internalRep.longValue + 1; TclSetLongObj(valuePtr, iterNum); /* @@ -5494,15 +6812,14 @@ TclExecuteByteCode( varListPtr = infoPtr->varLists[i]; numVars = varListPtr->numVars; - listVarPtr = &(compiledLocals[listTmpIndex]); + listVarPtr = LOCAL(listTmpIndex); listPtr = listVarPtr->value.objPtr; - result = Tcl_ListObjLength(interp, listPtr, &listLen); - if (result != TCL_OK) { - TRACE_WITH_OBJ(("%u => ERROR converting list %ld, \"%s\": ", - opnd, i, O2S(listPtr)), Tcl_GetObjResult(interp)); - goto checkForCatch; + if (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 (listLen > (iterNum * numVars)) { + if (listLen > iterNum * numVars) { continueLoop = 1; } listTmpIndex++; @@ -5523,9 +6840,9 @@ TclExecuteByteCode( varListPtr = infoPtr->varLists[i]; numVars = varListPtr->numVars; - listVarPtr = &(compiledLocals[listTmpIndex]); - listPtr = listVarPtr->value.objPtr; - Tcl_ListObjGetElements(interp, listPtr, &listLen, &elements); + listVarPtr = LOCAL(listTmpIndex); + listPtr = TclListObjCopy(NULL, listVarPtr->value.objPtr); + TclListObjGetElements(interp, listPtr, &listLen, &elements); valIndex = (iterNum * numVars); for (j = 0; j < numVars; j++) { @@ -5536,8 +6853,7 @@ TclExecuteByteCode( } varIndex = varListPtr->varIndexes[j]; - varPtr = &(compiledLocals[varIndex]); - part1 = varPtr->name; + varPtr = LOCAL(varIndex); while (TclIsVarLink(varPtr)) { varPtr = varPtr->value.linkPtr; } @@ -5546,32 +6862,31 @@ TclExecuteByteCode( if (valuePtr != value2Ptr) { if (value2Ptr != NULL) { TclDecrRefCount(value2Ptr); - } else { - TclSetVarScalar(varPtr); - TclClearVarUndefined(varPtr); } varPtr->value.objPtr = valuePtr; Tcl_IncrRefCount(valuePtr); } } else { DECACHE_STACK_INFO(); - value2Ptr = TclPtrSetVar(interp, varPtr, NULL, part1, - NULL, valuePtr, TCL_LEAVE_ERR_MSG); - CACHE_STACK_INFO(); - if (value2Ptr == NULL) { - TRACE_WITH_OBJ(("%u => ERROR init. index temp %d: ", - opnd, varIndex), Tcl_GetObjResult(interp)); - result = TCL_ERROR; - goto checkForCatch; + if (TclPtrSetVar(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)))); + TclDecrRefCount(listPtr); + goto gotError; } + CACHE_STACK_INFO(); } valIndex++; } + TclDecrRefCount(listPtr); listTmpIndex++; } } - TRACE(("%u => %d lists, iter %d, %s loop\n", opnd, numLists, - iterNum, (continueLoop? "continue" : "exit"))); + TRACE_APPEND(("%d lists, iter %d, %s loop\n", + numLists, iterNum, (continueLoop? "continue" : "exit"))); /* * Run-time peep-hole optimisation: the compiler ALWAYS follows @@ -5585,6 +6900,200 @@ TclExecuteByteCode( } else { NEXT_INST_F((continueLoop? 5 : TclGetInt4AtPtr(pc+1)), 0, 0); } + + } + { + ForeachInfo *infoPtr; + Tcl_Obj *listPtr, **elements, *tmpPtr; + ForeachVarList *varListPtr; + int numLists, iterMax, listLen, numVars; + int iterTmp, iterNum, listTmpDepth; + 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 = 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)) { + objPtr = TclListObjCopy(NULL, listPtr); + 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 = INT2PTR(0); + tmpPtr->internalRep.twoPtrValue.ptr2 = INT2PTR(iterMax); + PUSH_OBJECT(tmpPtr); /* iterCounts object */ + + /* + * Store a pointer to the ForeachInfo struct; same dirty trick + * as above + */ + + TclNewObj(tmpPtr); + tmpPtr->internalRep.otherValuePtr = 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 = tmpPtr->internalRep.otherValuePtr; + numLists = infoPtr->numLists; + TRACE(("=> ")); + + tmpPtr = OBJ_AT_DEPTH(1); + iterNum = PTR2INT(tmpPtr->internalRep.twoPtrValue.ptr1); + iterMax = PTR2INT(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) { + /* + * Set the variables and jump back to run the body + */ + + tmpPtr->internalRep.twoPtrValue.ptr1 = INT2PTR(iterNum + 1); + + listTmpDepth = numLists + 1; + + for (i = 0; i < numLists; i++) { + varListPtr = infoPtr->varLists[i]; + numVars = varListPtr->numVars; + + listPtr = OBJ_AT_DEPTH(listTmpDepth); + TclListObjGetElements(interp, listPtr, &listLen, &elements); + + valIndex = (iterNum * numVars); + for (j = 0; j < numVars; j++) { + if (valIndex >= listLen) { + TclNewObj(valuePtr); + } else { + valuePtr = elements[valIndex]; + } + + 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 (TclPtrSetVar(interp, varPtr, NULL, NULL, NULL, + valuePtr, TCL_LEAVE_ERR_MSG, varIndex)==NULL){ + CACHE_STACK_INFO(); + TRACE_APPEND(("ERROR init. index temp %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 = tmpPtr->internalRep.otherValuePtr; + 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 = tmpPtr->internalRep.otherValuePtr; + numLists = infoPtr->numLists; + TRACE_APPEND(("=> appending to list at depth %d\n", 3 + numLists)); + + objPtr = OBJ_AT_DEPTH(3 + numLists); + Tcl_ListObjAppendElement(NULL, objPtr, OBJ_AT_TOS); + NEXT_INST_F(1, 1, 0); } case INST_BEGIN_CATCH4: @@ -5593,16 +7102,20 @@ TclExecuteByteCode( * to the operand. Push the current stack depth onto the special catch * stack. */ - eePtr->stackPtr[++catchTop] = (Tcl_Obj *) (tosPtr - eePtr->stackPtr); + + *(++catchTop) = CURR_DEPTH; TRACE(("%u => catchTop=%d, stackTop=%d\n", - TclGetUInt4AtPtr(pc+1), (catchTop - initCatchTop - 1), - tosPtr - eePtr->stackPtr)); + TclGetUInt4AtPtr(pc+1), (int) (catchTop - initCatchTop - 1), + (int) CURR_DEPTH)); NEXT_INST_F(5, 0, 0); case INST_END_CATCH: catchTop--; + DECACHE_STACK_INFO(); + Tcl_ResetResult(interp); + CACHE_STACK_INFO(); result = TCL_OK; - TRACE(("=> catchTop=%d\n", (catchTop - initCatchTop - 1))); + TRACE(("=> catchTop=%d\n", (int) (catchTop - initCatchTop - 1))); NEXT_INST_F(1, 0, 0); case INST_PUSH_RESULT: @@ -5612,13 +7125,10 @@ TclExecuteByteCode( /* * See the comments at INST_INVOKE_STK */ - { - Tcl_Obj *newObjResultPtr; - TclNewObj(newObjResultPtr); - Tcl_IncrRefCount(newObjResultPtr); - iPtr->objResultPtr = newObjResultPtr; - } + TclNewObj(objPtr); + Tcl_IncrRefCount(objPtr); + iPtr->objResultPtr = objPtr; NEXT_INST_F(1, 0, -1); case INST_PUSH_RETURN_CODE: @@ -5627,53 +7137,115 @@ TclExecuteByteCode( NEXT_INST_F(1, 0, 1); case INST_PUSH_RETURN_OPTIONS: + DECACHE_STACK_INFO(); objResultPtr = Tcl_GetReturnOptions(interp, result); + CACHE_STACK_INFO(); TRACE_WITH_OBJ(("=> "), objResultPtr); NEXT_INST_F(1, 0, 1); -/* TODO: normalize "valPtr" to "valuePtr" */ + 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. + */ + { - int opnd, opnd2, allocateDict; - Tcl_Obj *dictPtr, *valPtr; - Var *varPtr; - char *part1; + int opnd2, allocateDict, done, i, allocdict; + Tcl_Obj *dictPtr, *statePtr, *keyPtr, *listPtr, *varNamePtr, *keysPtr; + Tcl_Obj *emptyPtr, **keyPtrPtr; + Tcl_DictSearch *searchPtr; + DictUpdateInfo *duiPtr; + + case INST_DICT_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); case INST_DICT_GET: + case INST_DICT_EXISTS: { + register Tcl_Interp *interp2 = interp; + register int found; + opnd = TclGetUInt4AtPtr(pc+1); TRACE(("%u => ", opnd)); - dictPtr = *(tosPtr - opnd); + dictPtr = OBJ_AT_DEPTH(opnd); + if (*pc == INST_DICT_EXISTS) { + interp2 = NULL; + } if (opnd > 1) { - dictPtr = TclTraceDictPath(interp, dictPtr, opnd-1, - tosPtr - (opnd-1), DICT_PATH_READ); + dictPtr = TclTraceDictPath(interp2, dictPtr, opnd-1, + &OBJ_AT_DEPTH(opnd-1), DICT_PATH_READ); if (dictPtr == NULL) { + if (*pc == INST_DICT_EXISTS) { + found = 0; + goto afterDictExists; + } TRACE_WITH_OBJ(( - "%u => ERROR tracing dictionary path into \"%s\": ", - opnd, O2S(*(tosPtr - opnd))), + "ERROR tracing dictionary path into \"%.30s\": ", + O2S(OBJ_AT_DEPTH(opnd))), Tcl_GetObjResult(interp)); - result = TCL_ERROR; - cleanup = opnd + 1; - goto checkForCatch; + goto gotError; } } - result = Tcl_DictObjGet(interp, dictPtr, *tosPtr, &objResultPtr); - if (result != TCL_OK) { - TRACE_WITH_OBJ(( - "%u => ERROR reading leaf dictionary key \"%s\": ", - opnd, O2S(dictPtr)), Tcl_GetObjResult(interp)); - cleanup = opnd + 1; - goto checkForCatch; - } - if (objResultPtr == NULL) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "key \"", TclGetString(*tosPtr), - "\" not known in dictionary", NULL); - TRACE_WITH_OBJ(("%u => ERROR ", opnd), Tcl_GetObjResult(interp)); - result = TCL_ERROR; - cleanup = opnd + 1; - goto checkForCatch; + if (Tcl_DictObjGet(interp2, dictPtr, OBJ_AT_TOS, + &objResultPtr) == TCL_OK) { + if (*pc == INST_DICT_EXISTS) { + found = (objResultPtr ? 1 : 0); + goto afterDictExists; + } + if (!objResultPtr) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "key \"%s\" not known in dictionary", + TclGetString(OBJ_AT_TOS))); + DECACHE_STACK_INFO(); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "DICT", + TclGetString(OBJ_AT_TOS), NULL); + CACHE_STACK_INFO(); + TRACE_ERROR(interp); + goto gotError; + } + TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); + NEXT_INST_V(5, opnd+1, 1); + } else if (*pc != INST_DICT_EXISTS) { + TRACE_APPEND(("ERROR reading leaf dictionary key \"%.30s\": %s", + O2S(dictPtr), O2S(Tcl_GetObjResult(interp)))); + goto gotError; + } else { + found = 0; } - TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); - NEXT_INST_V(5, opnd+1, 1); + afterDictExists: + TRACE_APPEND(("%d\n", found)); + + /* + * 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_SET: case INST_DICT_UNSET: @@ -5681,8 +7253,7 @@ TclExecuteByteCode( opnd = TclGetUInt4AtPtr(pc+1); opnd2 = TclGetUInt4AtPtr(pc+5); - varPtr = &(compiledLocals[opnd2]); - part1 = varPtr->name; + varPtr = LOCAL(opnd2); while (TclIsVarLink(varPtr)) { varPtr = varPtr->value.linkPtr; } @@ -5691,7 +7262,7 @@ TclExecuteByteCode( dictPtr = varPtr->value.objPtr; } else { DECACHE_STACK_INFO(); - dictPtr = TclPtrGetVar(interp, varPtr, NULL, part1, NULL, 0); + dictPtr = TclPtrGetVar(interp, varPtr, NULL,NULL,NULL, 0, opnd2); CACHE_STACK_INFO(); } if (dictPtr == NULL) { @@ -5707,36 +7278,36 @@ TclExecuteByteCode( switch (*pc) { case INST_DICT_SET: cleanup = opnd + 1; - result = Tcl_DictObjPutKeyList(interp, dictPtr, opnd, tosPtr-opnd, - *tosPtr); + result = Tcl_DictObjPutKeyList(interp, dictPtr, opnd, + &OBJ_AT_DEPTH(opnd), OBJ_AT_TOS); break; case INST_DICT_INCR_IMM: cleanup = 1; opnd = TclGetInt4AtPtr(pc+1); - result = Tcl_DictObjGet(interp, dictPtr, *tosPtr, &valPtr); + result = Tcl_DictObjGet(interp, dictPtr, OBJ_AT_TOS, &valuePtr); if (result != TCL_OK) { break; } - if (valPtr == NULL) { - Tcl_DictObjPut(NULL, dictPtr, *tosPtr, Tcl_NewIntObj(opnd)); + if (valuePtr == NULL) { + Tcl_DictObjPut(NULL, dictPtr, OBJ_AT_TOS,Tcl_NewIntObj(opnd)); } else { - Tcl_Obj *incrPtr = Tcl_NewIntObj(opnd); - Tcl_IncrRefCount(incrPtr); - if (Tcl_IsShared(valPtr)) { - valPtr = Tcl_DuplicateObj(valPtr); - Tcl_DictObjPut(NULL, dictPtr, *tosPtr, valPtr); + value2Ptr = Tcl_NewIntObj(opnd); + Tcl_IncrRefCount(value2Ptr); + if (Tcl_IsShared(valuePtr)) { + valuePtr = Tcl_DuplicateObj(valuePtr); + Tcl_DictObjPut(NULL, dictPtr, OBJ_AT_TOS, valuePtr); } - result = TclIncrObj(interp, valPtr, incrPtr); + result = TclIncrObj(interp, valuePtr, value2Ptr); if (result == TCL_OK) { - Tcl_InvalidateStringRep(dictPtr); + TclInvalidateStringRep(dictPtr); } - Tcl_DecrRefCount(incrPtr); + TclDecrRefCount(value2Ptr); } break; case INST_DICT_UNSET: cleanup = opnd; result = Tcl_DictObjRemoveKeyList(interp, dictPtr, opnd, - tosPtr - (opnd-1)); + &OBJ_AT_DEPTH(opnd-1)); break; default: cleanup = 0; /* stop compiler warning */ @@ -5745,23 +7316,19 @@ TclExecuteByteCode( if (result != TCL_OK) { if (allocateDict) { - Tcl_DecrRefCount(dictPtr); + TclDecrRefCount(dictPtr); } - TRACE_WITH_OBJ(("%u %u => ERROR updating dictionary: ",opnd,opnd2), - Tcl_GetObjResult(interp)); + TRACE_APPEND(("ERROR updating dictionary: %s\n", + O2S(Tcl_GetObjResult(interp)))); goto checkForCatch; } if (TclIsVarDirectWritable(varPtr)) { if (allocateDict) { - Tcl_Obj *oldValuePtr = varPtr->value.objPtr; - + value2Ptr = varPtr->value.objPtr; Tcl_IncrRefCount(dictPtr); - if (oldValuePtr != NULL) { - Tcl_DecrRefCount(oldValuePtr); - } else { - TclSetVarScalar(varPtr); - TclClearVarUndefined(varPtr); + if (value2Ptr != NULL) { + TclDecrRefCount(value2Ptr); } varPtr->value.objPtr = dictPtr; } @@ -5769,14 +7336,13 @@ TclExecuteByteCode( } else { Tcl_IncrRefCount(dictPtr); DECACHE_STACK_INFO(); - objResultPtr = TclPtrSetVar(interp, varPtr, NULL, part1, NULL, - dictPtr, TCL_LEAVE_ERR_MSG); + objResultPtr = TclPtrSetVar(interp, varPtr, NULL, NULL, NULL, + dictPtr, TCL_LEAVE_ERR_MSG, opnd2); CACHE_STACK_INFO(); - Tcl_DecrRefCount(dictPtr); + TclDecrRefCount(dictPtr); if (objResultPtr == NULL) { - TRACE_APPEND(("ERROR: %.30s\n",O2S(Tcl_GetObjResult(interp)))); - result = TCL_ERROR; - goto checkForCatch; + TRACE_ERROR(interp); + goto gotError; } } #ifndef TCL_COMPILE_DEBUG @@ -5784,16 +7350,13 @@ TclExecuteByteCode( 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); - cleanup = 2; - - varPtr = &(compiledLocals[opnd]); - part1 = varPtr->name; + varPtr = LOCAL(opnd); while (TclIsVarLink(varPtr)) { varPtr = varPtr->value.linkPtr; } @@ -5802,7 +7365,7 @@ TclExecuteByteCode( dictPtr = varPtr->value.objPtr; } else { DECACHE_STACK_INFO(); - dictPtr = TclPtrGetVar(interp, varPtr, NULL, part1, NULL, 0); + dictPtr = TclPtrGetVar(interp, varPtr, NULL, NULL, NULL, 0, opnd); CACHE_STACK_INFO(); } if (dictPtr == NULL) { @@ -5815,29 +7378,41 @@ TclExecuteByteCode( } } - result = Tcl_DictObjGet(interp, dictPtr, *(tosPtr - 1), &valPtr); - if (result != TCL_OK) { + if (Tcl_DictObjGet(interp, dictPtr, OBJ_UNDER_TOS, + &valuePtr) != TCL_OK) { if (allocateDict) { - Tcl_DecrRefCount(dictPtr); + TclDecrRefCount(dictPtr); } - goto checkForCatch; + TRACE_ERROR(interp); + goto gotError; } /* - * Note that a non-existent key results in a NULL valPtr, which is a + * Note that a non-existent key results in a NULL valuePtr, which is a * case handled separately below. What we *can* say at this point is * that the write-back will always succeed. */ switch (*pc) { case INST_DICT_APPEND: - if (valPtr == NULL) { - valPtr = *tosPtr; + if (valuePtr == NULL) { + Tcl_DictObjPut(NULL, dictPtr, OBJ_UNDER_TOS, OBJ_AT_TOS); + } else if (Tcl_IsShared(valuePtr)) { + valuePtr = Tcl_DuplicateObj(valuePtr); + Tcl_AppendObjToObj(valuePtr, OBJ_AT_TOS); + Tcl_DictObjPut(NULL, dictPtr, OBJ_UNDER_TOS, valuePtr); } else { - if (Tcl_IsShared(valPtr)) { - valPtr = Tcl_DuplicateObj(valPtr); - } - Tcl_AppendObjToObj(valPtr, *tosPtr); + Tcl_AppendObjToObj(valuePtr, OBJ_AT_TOS); + + /* + * Must invalidate the string representation of dictionary + * here because we have directly updated the internal + * representation; if we don't, callers could see the wrong + * string rep despite the internal version of the dictionary + * having the correct value. [Bug 3079830] + */ + + TclInvalidateStringRep(dictPtr); } break; case INST_DICT_LAPPEND: @@ -5845,44 +7420,53 @@ TclExecuteByteCode( * More complex because list-append can fail. */ - if (valPtr == NULL) { - valPtr = Tcl_NewListObj(1, tosPtr); - } else if (Tcl_IsShared(valPtr)) { - valPtr = Tcl_DuplicateObj(valPtr); - result = Tcl_ListObjAppendElement(interp, valPtr, *tosPtr); - if (result != TCL_OK) { - Tcl_DecrRefCount(valPtr); + if (valuePtr == NULL) { + Tcl_DictObjPut(NULL, dictPtr, OBJ_UNDER_TOS, + Tcl_NewListObj(1, &OBJ_AT_TOS)); + break; + } else if (Tcl_IsShared(valuePtr)) { + valuePtr = Tcl_DuplicateObj(valuePtr); + if (Tcl_ListObjAppendElement(interp, valuePtr, + OBJ_AT_TOS) != TCL_OK) { + TclDecrRefCount(valuePtr); if (allocateDict) { - Tcl_DecrRefCount(dictPtr); + TclDecrRefCount(dictPtr); } - goto checkForCatch; + TRACE_ERROR(interp); + goto gotError; } + Tcl_DictObjPut(NULL, dictPtr, OBJ_UNDER_TOS, valuePtr); } else { - result = Tcl_ListObjAppendElement(interp, valPtr, *tosPtr); - if (result != TCL_OK) { + if (Tcl_ListObjAppendElement(interp, valuePtr, + OBJ_AT_TOS) != TCL_OK) { if (allocateDict) { - Tcl_DecrRefCount(dictPtr); + TclDecrRefCount(dictPtr); } - goto checkForCatch; + TRACE_ERROR(interp); + goto gotError; } + + /* + * Must invalidate the string representation of dictionary + * here because we have directly updated the internal + * representation; if we don't, callers could see the wrong + * string rep despite the internal version of the dictionary + * having the correct value. [Bug 3079830] + */ + + TclInvalidateStringRep(dictPtr); } break; default: Tcl_Panic("Should not happen!"); } - Tcl_DictObjPut(NULL, dictPtr, *(tosPtr - 1), valPtr); - if (TclIsVarDirectWritable(varPtr)) { if (allocateDict) { - Tcl_Obj *oldValuePtr = varPtr->value.objPtr; - + value2Ptr = varPtr->value.objPtr; Tcl_IncrRefCount(dictPtr); - if (oldValuePtr != NULL) { - Tcl_DecrRefCount(oldValuePtr); - } else { - TclSetVarScalar(varPtr); - TclClearVarUndefined(varPtr); + if (value2Ptr != NULL) { + TclDecrRefCount(value2Ptr); } varPtr->value.objPtr = dictPtr; } @@ -5890,14 +7474,13 @@ TclExecuteByteCode( } else { Tcl_IncrRefCount(dictPtr); DECACHE_STACK_INFO(); - objResultPtr = TclPtrSetVar(interp, varPtr, NULL, part1, NULL, - dictPtr, TCL_LEAVE_ERR_MSG); + objResultPtr = TclPtrSetVar(interp, varPtr, NULL, NULL, NULL, + dictPtr, TCL_LEAVE_ERR_MSG, opnd); CACHE_STACK_INFO(); - Tcl_DecrRefCount(dictPtr); + TclDecrRefCount(dictPtr); if (objResultPtr == NULL) { - TRACE_APPEND(("ERROR: %.30s\n",O2S(Tcl_GetObjResult(interp)))); - result = TCL_ERROR; - goto checkForCatch; + TRACE_ERROR(interp); + goto gotError; } } #ifndef TCL_COMPILE_DEBUG @@ -5907,38 +7490,28 @@ TclExecuteByteCode( #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)); - result = Tcl_DictObjFirst(interp, dictPtr, searchPtr, &keyPtr, - &valuePtr, &done); - if (result != TCL_OK) { - ckfree((char *) searchPtr); - cleanup = 0; - goto checkForCatch; + searchPtr = ckalloc(sizeof(Tcl_DictSearch)); + if (Tcl_DictObjFirst(interp, dictPtr, searchPtr, &keyPtr, + &valuePtr, &done) != TCL_OK) { + ckfree(searchPtr); + TRACE_ERROR(interp); + goto gotError; } TclNewObj(statePtr); statePtr->typePtr = &dictIteratorType; - statePtr->internalRep.twoPtrValue.ptr1 = (void *) searchPtr; - statePtr->internalRep.twoPtrValue.ptr2 = (void *) dictPtr; - varPtr = compiledLocals + opnd; - if (varPtr->value.objPtr == NULL) { - TclSetVarScalar(compiledLocals + opnd); - TclClearVarUndefined(compiledLocals + opnd); - } else if (varPtr->value.objPtr->typePtr == &dictIteratorType) { - Tcl_Panic("mis-issued dictFirst!"); - } else { - Tcl_DecrRefCount(varPtr->value.objPtr); + statePtr->internalRep.twoPtrValue.ptr1 = searchPtr; + statePtr->internalRep.twoPtrValue.ptr2 = dictPtr; + varPtr = LOCAL(opnd); + if (varPtr->value.objPtr) { + if (varPtr->value.objPtr->typePtr == &dictIteratorType) { + Tcl_Panic("mis-issued dictFirst!"); + } + TclDecrRefCount(varPtr->value.objPtr); } varPtr->value.objPtr = statePtr; Tcl_IncrRefCount(statePtr); @@ -5947,11 +7520,11 @@ TclExecuteByteCode( case INST_DICT_NEXT: opnd = TclGetUInt4AtPtr(pc+1); TRACE(("%u => ", opnd)); - statePtr = compiledLocals[opnd].value.objPtr; + statePtr = (*LOCAL(opnd)).value.objPtr; if (statePtr == NULL || statePtr->typePtr != &dictIteratorType) { Tcl_Panic("mis-issued dictNext!"); } - searchPtr = (Tcl_DictSearch *) statePtr->internalRep.twoPtrValue.ptr1; + searchPtr = statePtr->internalRep.twoPtrValue.ptr1; Tcl_DictObjNext(searchPtr, &keyPtr, &valuePtr, &done); pushDictIteratorResult: if (done) { @@ -5962,233 +7535,242 @@ TclExecuteByteCode( PUSH_OBJECT(valuePtr); PUSH_OBJECT(keyPtr); } - TRACE_APPEND(("\"%.30s\" \"%.30s\" %d", - O2S(*(tosPtr-1)), O2S(*tosPtr), done)); - objResultPtr = eePtr->constants[done]; - /*TODO: consider opt like INST_FOREACH_STEP4 */ - NEXT_INST_F(5, 0, 1); + TRACE_APPEND(("\"%.30s\" \"%.30s\" %d\n", + O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS), done)); - 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. - */ - - searchPtr = (Tcl_DictSearch *) - statePtr->internalRep.twoPtrValue.ptr1; - Tcl_DictObjDone(searchPtr); - ckfree((char *) searchPtr); - - dictPtr = (Tcl_Obj *) statePtr->internalRep.twoPtrValue.ptr2; - Tcl_DecrRefCount(dictPtr); - - /* - * Set the internal variable to an empty object to signify that we - * don't hold an iterator. - */ - - Tcl_DecrRefCount(statePtr); - TclNewObj(emptyPtr); - compiledLocals[opnd].value.objPtr = emptyPtr; - Tcl_IncrRefCount(emptyPtr); - } - NEXT_INST_F(5, 0, 0); - } + /* + * The INST_DICT_FIRST and INST_DICT_NEXT instructsions are always + * followed by a conditional jump, so we can take advantage of this to + * do some peephole optimization (note that we're careful to not close + * out someone doing something else). + */ - { - int opnd, i, length, length2, allocdict; - Tcl_Obj **keyPtrPtr, **varIdxPtrPtr, *dictPtr; - Var *varPtr; - char *part1; + JUMP_PEEPHOLE_F(done, 5, 0); case INST_DICT_UPDATE_START: opnd = TclGetUInt4AtPtr(pc+1); - varPtr = &(compiledLocals[opnd]); - part1 = varPtr->name; + opnd2 = TclGetUInt4AtPtr(pc+5); + TRACE(("%u => ", opnd)); + varPtr = LOCAL(opnd); + duiPtr = codePtr->auxDataArrayPtr[opnd2].clientData; while (TclIsVarLink(varPtr)) { varPtr = varPtr->value.linkPtr; } - TRACE(("%u => ", opnd)); if (TclIsVarDirectReadable(varPtr)) { dictPtr = varPtr->value.objPtr; } else { DECACHE_STACK_INFO(); - dictPtr = TclPtrGetVar(interp, varPtr, NULL, part1, NULL, - TCL_LEAVE_ERR_MSG); + dictPtr = TclPtrGetVar(interp, varPtr, NULL, NULL, NULL, + TCL_LEAVE_ERR_MSG, opnd); CACHE_STACK_INFO(); if (dictPtr == NULL) { - goto dictUpdateStartFailed; + TRACE_ERROR(interp); + goto gotError; } } - if (Tcl_ListObjGetElements(interp, *(tosPtr - 1), &length, - &keyPtrPtr) != TCL_OK || - Tcl_ListObjGetElements(interp, *tosPtr, &length2, - &varIdxPtrPtr) != TCL_OK) { - goto dictUpdateStartFailed; + if (TclListObjGetElements(interp, OBJ_AT_TOS, &length, + &keyPtrPtr) != TCL_OK) { + TRACE_ERROR(interp); + goto gotError; } - if (length != length2) { + if (length != duiPtr->length) { Tcl_Panic("dictUpdateStart argument length mismatch"); } for (i=0 ; i<length ; i++) { - Tcl_Obj *valPtr; - int varIdx; - if (Tcl_DictObjGet(interp, dictPtr, keyPtrPtr[i], - &valPtr) != TCL_OK) { - goto dictUpdateStartFailed; + &valuePtr) != TCL_OK) { + TRACE_ERROR(interp); + goto gotError; } - Tcl_GetIntFromObj(NULL, varIdxPtrPtr[i], &varIdx); - varPtr = &(compiledLocals[varIdx]); - part1 = varPtr->name; + varPtr = LOCAL(duiPtr->varIndices[i]); while (TclIsVarLink(varPtr)) { varPtr = varPtr->value.linkPtr; } DECACHE_STACK_INFO(); - if (valPtr == NULL) { - Tcl_UnsetVar(interp, part1, 0); - } else if (TclPtrSetVar(interp, varPtr, NULL, part1, NULL, - valPtr, TCL_LEAVE_ERR_MSG) == NULL) { + if (valuePtr == NULL) { + TclObjUnsetVar2(interp, + localName(iPtr->varFramePtr, duiPtr->varIndices[i]), + NULL, 0); + } else if (TclPtrSetVar(interp, varPtr, NULL, NULL, NULL, + valuePtr, TCL_LEAVE_ERR_MSG, + duiPtr->varIndices[i]) == NULL) { CACHE_STACK_INFO(); - dictUpdateStartFailed: - cleanup = 2; - result = TCL_ERROR; - goto checkForCatch; + TRACE_ERROR(interp); + goto gotError; } CACHE_STACK_INFO(); } - NEXT_INST_F(5, 2, 0); + TRACE_APPEND(("OK\n")); + NEXT_INST_F(9, 0, 0); case INST_DICT_UPDATE_END: opnd = TclGetUInt4AtPtr(pc+1); - varPtr = &(compiledLocals[opnd]); - part1 = varPtr->name; + opnd2 = TclGetUInt4AtPtr(pc+5); + TRACE(("%u => ", opnd)); + varPtr = LOCAL(opnd); + duiPtr = codePtr->auxDataArrayPtr[opnd2].clientData; while (TclIsVarLink(varPtr)) { varPtr = varPtr->value.linkPtr; } - TRACE(("%u => ", opnd)); if (TclIsVarDirectReadable(varPtr)) { dictPtr = varPtr->value.objPtr; } else { DECACHE_STACK_INFO(); - dictPtr = TclPtrGetVar(interp, varPtr, NULL, part1, NULL, 0); + dictPtr = TclPtrGetVar(interp, varPtr, NULL, NULL, NULL, 0, opnd); CACHE_STACK_INFO(); } if (dictPtr == NULL) { - NEXT_INST_F(5, 2, 0); - } - if (Tcl_DictObjSize(interp, dictPtr, &length) != TCL_OK || - Tcl_ListObjGetElements(interp, *(tosPtr - 1), &length, - &keyPtrPtr) != TCL_OK || - Tcl_ListObjGetElements(interp, *tosPtr, &length2, - &varIdxPtrPtr) != TCL_OK) { - cleanup = 2; - result = TCL_ERROR; - goto checkForCatch; + 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; } allocdict = Tcl_IsShared(dictPtr); if (allocdict) { dictPtr = Tcl_DuplicateObj(dictPtr); } + if (length > 0) { + TclInvalidateStringRep(dictPtr); + } for (i=0 ; i<length ; i++) { - Tcl_Obj *valPtr; - int varIdx; - Var *var2Ptr; - char *part1a; - - Tcl_GetIntFromObj(NULL, varIdxPtrPtr[i], &varIdx); - var2Ptr = &(compiledLocals[varIdx]); - part1a = var2Ptr->name; + Var *var2Ptr = LOCAL(duiPtr->varIndices[i]); + while (TclIsVarLink(var2Ptr)) { var2Ptr = var2Ptr->value.linkPtr; } if (TclIsVarDirectReadable(var2Ptr)) { - valPtr = var2Ptr->value.objPtr; + valuePtr = var2Ptr->value.objPtr; } else { DECACHE_STACK_INFO(); - valPtr = TclPtrGetVar(interp, var2Ptr, NULL, part1a, NULL, 0); + valuePtr = TclPtrGetVar(interp, var2Ptr, NULL, NULL, NULL, 0, + duiPtr->varIndices[i]); CACHE_STACK_INFO(); } - if (valPtr == NULL) { + if (valuePtr == NULL) { Tcl_DictObjRemove(interp, dictPtr, keyPtrPtr[i]); + } else if (dictPtr == valuePtr) { + Tcl_DictObjPut(interp, dictPtr, keyPtrPtr[i], + Tcl_DuplicateObj(valuePtr)); } else { - Tcl_DictObjPut(interp, dictPtr, keyPtrPtr[i], valPtr); + Tcl_DictObjPut(interp, dictPtr, keyPtrPtr[i], valuePtr); } } if (TclIsVarDirectWritable(varPtr)) { Tcl_IncrRefCount(dictPtr); - Tcl_DecrRefCount(varPtr->value.objPtr); + TclDecrRefCount(varPtr->value.objPtr); varPtr->value.objPtr = dictPtr; } else { DECACHE_STACK_INFO(); - objResultPtr = TclPtrSetVar(interp, varPtr, NULL, part1, NULL, - dictPtr, TCL_LEAVE_ERR_MSG); + objResultPtr = TclPtrSetVar(interp, varPtr, NULL, NULL, NULL, + dictPtr, TCL_LEAVE_ERR_MSG, opnd); CACHE_STACK_INFO(); if (objResultPtr == NULL) { if (allocdict) { - Tcl_DecrRefCount(dictPtr); + TclDecrRefCount(dictPtr); } - cleanup = 2; - result = TCL_ERROR; - goto checkForCatch; + TRACE_ERROR(interp); + goto gotError; } } - NEXT_INST_F(5, 2, 0); - } + TRACE_APPEND(("written back\n")); + NEXT_INST_F(9, 1, 0); - default: - Tcl_Panic("TclExecuteByteCode: unrecognized opCode %u", *pc); - } /* end of switch on opCode */ - - /* - * Division by zero in an expression. Control only reaches this point by - * "goto divideByZero". - */ + 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); - divideByZero: - Tcl_SetObjResult(interp, Tcl_NewStringObj("divide by zero", -1)); - Tcl_SetErrorCode(interp, "ARITH", "DIVZERO", "divide by zero", - (char *) NULL); + 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); - result = TCL_ERROR; - goto checkForCatch; + 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); + } /* - * Exponentiation of zero by negative number in an expression. Control - * only reaches this point by "goto exponOfZero". + * End of dictionary-related instructions. + * ----------------------------------------------------------------- */ - exponOfZero: - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "exponentiation of zero by negative power", -1)); - Tcl_SetErrorCode(interp, "ARITH", "DOMAIN", - "exponentiation of zero by negative power", (char *) NULL); - result = TCL_ERROR; - goto checkForCatch; + default: + Tcl_Panic("TclNRExecuteByteCode: unrecognized opCode %u", *pc); + } /* end of switch on opCode */ /* - * Block for variables needed to process exception returns + * Block for variables needed to process exception returns. */ { - ExceptionRange *rangePtr; /* Points to closest loop or catch - * exception range enclosing the pc. Used - * by various instructions and processCatch - * to process break, continue, and - * errors. */ - Tcl_Obj *valuePtr; - char *bytes; - int length; -#if TCL_COMPILE_DEBUG - int opnd; -#endif + ExceptionRange *rangePtr; + /* Points to closest loop or catch exception + * range enclosing the pc. Used by various + * instructions and processCatch to process + * break, continue, and errors. */ + const char *bytes; /* * An external evaluation (INST_INVOKE or INST_EVAL) returned @@ -6197,7 +7779,7 @@ TclExecuteByteCode( */ processExceptionReturn: -#if TCL_COMPILE_DEBUG +#ifdef TCL_COMPILE_DEBUG switch (*pc) { case INST_INVOKE_STK1: opnd = TclGetUInt1AtPtr(pc+1); @@ -6213,7 +7795,7 @@ TclExecuteByteCode( * the cleanup. */ - TRACE(("\"%.30s\" => ", O2S(*tosPtr))); + TRACE(("\"%.30s\" => ", O2S(OBJ_AT_TOS))); break; default: TRACE(("=> ")); @@ -6241,32 +7823,65 @@ TclExecuteByteCode( 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 TCL_COMPILE_DEBUG - } else if (traceInstructions) { - if ((result != TCL_ERROR) && (result != TCL_RETURN)) { - Tcl_Obj *objPtr = Tcl_GetObjResult(interp); - TRACE_APPEND(("OTHER RETURN CODE %d, result= \"%s\"\n ", + 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); + } +#ifdef TCL_COMPILE_DEBUG + if (traceInstructions) { + objPtr = Tcl_GetObjResult(interp); + if ((result != TCL_ERROR) && (result != TCL_RETURN)) { + TRACE_APPEND(("OTHER RETURN CODE %d, result=\"%.30s\"\n ", result, O2S(objPtr))); } else { - Tcl_Obj *objPtr = Tcl_GetObjResult(interp); - TRACE_APPEND(("%s, result= \"%s\"\n", + TRACE_APPEND(("%s, result=\"%.30s\"\n", StringForResultCode(result), O2S(objPtr))); } -#endif } +#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", 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", 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 @@ -6276,12 +7891,18 @@ TclExecuteByteCode( * and return the "exception" code. */ - checkForCatch: + checkForCatch: + if (iPtr->execEnvPtr->rewind) { + goto abnormalReturn; + } if ((result == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) { - bytes = GetSrcInfoForPc(pc, codePtr, &length); - if (bytes != NULL) { - Tcl_LogCommandInfo(interp, codePtr->source, bytes, length); - } + 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(); } iPtr->flags &= ~ERR_ALREADY_LOGGED; @@ -6290,20 +7911,41 @@ TclExecuteByteCode( * INST_BEGIN_CATCH. */ - while ((expandNestList != NULL) && ((catchTop == initCatchTop) || - ((ptrdiff_t) eePtr->stackPtr[catchTop] <= - (ptrdiff_t) expandNestList->internalRep.twoPtrValue.ptr1))) { - Tcl_Obj *objPtr = expandNestList->internalRep.twoPtrValue.ptr2; - TclDecrRefCount(expandNestList); - expandNestList = objPtr; + while (auxObjList) { + if ((catchTop != initCatchTop) + && (*catchTop > (ptrdiff_t) + auxObjList->internalRep.ptrAndLongRep.value)) { + break; + } + POP_TAUX_OBJ(); } /* - * We must not catch an exceeded limit. Instead, it blows outwards + * We must not catch if the script in progress has been canceled with + * the TCL_CANCEL_UNWIND flag. Instead, it blows outwards until we + * either hit another interpreter (presumably where the script in + * progress has not been canceled) or we get to the top-level. We do + * NOT modify the interpreter result here because we know it will + * already be set prior to vectoring down to this point in the code. + */ + + if (TclCanceled(iPtr) && (Tcl_Canceled(interp, 0) == TCL_ERROR)) { +#ifdef TCL_COMPILE_DEBUG + if (traceInstructions) { + fprintf(stdout, " ... cancel with unwind, returning %s\n", + StringForResultCode(result)); + } +#endif + goto abnormalReturn; + } + + /* + * We must not catch an exceeded limit. Instead, it blows outwards * until we either hit another interpreter (presumably where the limit * is not exceeded) or we get to the top-level. */ - if (Tcl_LimitExceeded(interp)) { + + if (TclLimitExceeded(iPtr->limit)) { #ifdef TCL_COMPILE_DEBUG if (traceInstructions) { fprintf(stdout, " ... limit exceeded, returning %s\n", @@ -6326,8 +7968,9 @@ TclExecuteByteCode( /* * This is only possible when compiling a [catch] that sends its * script to INST_EVAL. Cannot correct the compiler without - * breakingcompat with previous .tbc compiled scripts. + * breaking compat with previous .tbc compiled scripts. */ + #ifdef TCL_COMPILE_DEBUG if (traceInstructions) { fprintf(stdout, " ... no enclosing catch, returning %s\n", @@ -6340,26 +7983,26 @@ TclExecuteByteCode( /* * A catch exception range (rangePtr) was found to handle an * "exception". It was found either by checkForCatch just above or by - * an instruction during break, continue, or error processing. Jump - * to its catchOffset after unwinding the operand stack to the depth - * it had when starting to execute the range's catch command. + * an instruction during break, continue, or error processing. Jump to + * its catchOffset after unwinding the operand stack to the depth it + * had when starting to execute the range's catch command. */ - processCatch: - while (tosPtr > ((ptrdiff_t) (eePtr->stackPtr[catchTop])) + eePtr->stackPtr) { + processCatch: + while (CURR_DEPTH > *catchTop) { valuePtr = POP_OBJECT(); TclDecrRefCount(valuePtr); } #ifdef TCL_COMPILE_DEBUG if (traceInstructions) { - fprintf(stdout, " ... found catch at %d, catchTop=%d, unwound to %d, new pc %u\n", - rangePtr->codeOffset, (catchTop - initCatchTop - 1), - (int) eePtr->stackPtr[catchTop], - (unsigned int)(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); - NEXT_INST_F(0, 0, 0); /* restart the execution loop at pc */ + NEXT_INST_F(0, 0, 0); /* Restart the execution loop at pc. */ /* * end of infinite loop dispatching on instructions. @@ -6371,35 +8014,1499 @@ TclExecuteByteCode( * initial level. */ - abnormalReturn: + abnormalReturn: + TCL_DTRACE_INST_LAST(); + + /* + * Clear all expansions and same-level NR calls. + * + * Note that expansion markers have a NULL type; avoid removing other + * markers. + */ + + while (auxObjList) { + POP_TAUX_OBJ(); + } + while (tosPtr > initTosPtr) { + objPtr = POP_OBJECT(); + Tcl_DecrRefCount(objPtr); + } + + if (tosPtr < initTosPtr) { + fprintf(stderr, + "\nTclNRExecuteByteCode: abnormal return at pc %u: " + "stack top %d < entry stack top %d\n", + (unsigned)(pc - codePtr->codeStart), + (unsigned) CURR_DEPTH, (unsigned) 0); + Tcl_Panic("TclNRExecuteByteCode execution failure: end stack top < start stack top"); + } + CLANG_ASSERT(bcFramePtr); + } + + iPtr->cmdFramePtr = bcFramePtr->nextPtr; + if (--codePtr->refCount <= 0) { + TclCleanupByteCode(codePtr); + } + 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: { - Tcl_Obj **initTosPtr = eePtr->stackPtr + initStackTop; - while (tosPtr > initTosPtr) { - Tcl_Obj *objPtr = POP_OBJECT(); - TclDecrRefCount(objPtr); + const char *bytes; + + checkInterp = 1; + length = 0; + + /* + * We used to switch to direct eval; for NRE-awareness we now + * compile and eval the command so that this evaluation does not + * add a new TEBC instance. [Bug 2910748] + */ + + if (TclInterpReady(interp) == TCL_ERROR) { + goto gotError; + } + + codePtr->flags |= TCL_BYTECODE_RECOMPILE; + bytes = GetSrcInfoForPc(pc, codePtr, &length, NULL, NULL); + opnd = TclGetUInt4AtPtr(pc+1); + pc += (opnd-1); + PUSH_OBJECT(Tcl_NewStringObj(bytes, length)); + goto instEvalStk; + } +} + +#undef codePtr +#undef iPtr +#undef bcFramePtr +#undef initCatchTop +#undef initTosPtr +#undef auxObjList +#undef catchTop +#undef TCONST + +static int +FinalizeOONext( + ClientData data[], + Tcl_Interp *interp, + int result) +{ + Interp *iPtr = (Interp *) interp; + CallContext *contextPtr = data[1]; + + /* + * Reset the variable lookup frame. + */ + + iPtr->varFramePtr = 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; +} + +static int +FinalizeOONextFilter( + ClientData data[], + Tcl_Interp *interp, + int result) +{ + Interp *iPtr = (Interp *) interp; + CallContext *contextPtr = data[1]; + + /* + * Reset the variable lookup frame. + */ + + iPtr->varFramePtr = 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; +} + +/* + *---------------------------------------------------------------------- + * + * 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 LONG_RESULT(l) \ + if (Tcl_IsShared(valuePtr)) { \ + TclNewLongObj(objResultPtr, l); \ + return objResultPtr; \ + } else { \ + Tcl_SetLongObj(valuePtr, l); \ + return NULL; \ + } +#define WIDE_RESULT(w) \ + if (Tcl_IsShared(valuePtr)) { \ + return Tcl_NewWideIntObj(w); \ + } else { \ + Tcl_SetWideIntObj(valuePtr, w); \ + return NULL; \ + } +#define BIG_RESULT(b) \ + if (Tcl_IsShared(valuePtr)) { \ + return Tcl_NewBignumObj(b); \ + } else { \ + Tcl_SetBignumObj(valuePtr, b); \ + return NULL; \ + } +#define DOUBLE_RESULT(d) \ + if (Tcl_IsShared(valuePtr)) { \ + TclNewDoubleObj(objResultPtr, (d)); \ + return objResultPtr; \ + } else { \ + Tcl_SetDoubleObj(valuePtr, (d)); \ + return NULL; \ + } + + int type1, type2; + ClientData ptr1, ptr2; + double d1, d2, dResult; + long l1, l2, lResult; + Tcl_WideInt w1, w2, wResult; + mp_int big1, big2, bigResult, bigRemainder; + Tcl_Obj *objResultPtr; + int invalid, numPos, zero; + long shift; + + (void) GetNumberFromObj(NULL, valuePtr, &ptr1, &type1); + (void) GetNumberFromObj(NULL, value2Ptr, &ptr2, &type2); + + switch (opcode) { + case INST_MOD: + /* TODO: Attempts to re-use unshared operands on stack */ + + l2 = 0; /* silence gcc warning */ + if (type2 == TCL_NUMBER_LONG) { + l2 = *((const long *)ptr2); + if (l2 == 0) { + return DIVIDED_BY_ZERO; } + if ((l2 == 1) || (l2 == -1)) { + /* + * Div. by |1| always yields remainder of 0. + */ + + return constants[0]; + } + } +#ifndef TCL_WIDE_INT_IS_LONG + if (type1 == TCL_NUMBER_WIDE) { + w1 = *((const Tcl_WideInt *)ptr1); + if (type2 != TCL_NUMBER_BIG) { + Tcl_WideInt wQuotient, wRemainder; + Tcl_GetWideIntFromObj(NULL, value2Ptr, &w2); + wQuotient = w1 / w2; + + /* + * Force Tcl's integer division rules. + * TODO: examine for logic simplification + */ + + if (((wQuotient < (Tcl_WideInt) 0) + || ((wQuotient == (Tcl_WideInt) 0) + && ((w1 < (Tcl_WideInt)0 && w2 > (Tcl_WideInt)0) + || (w1 > (Tcl_WideInt)0 && w2 < (Tcl_WideInt)0)))) + && (wQuotient * w2 != w1)) { + wQuotient -= (Tcl_WideInt) 1; + } + wRemainder = w1 - w2*wQuotient; + WIDE_RESULT(wRemainder); + } + + Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2); + + /* TODO: internals intrusion */ + if ((w1 > ((Tcl_WideInt) 0)) ^ (big2.sign == MP_ZPOS)) { + /* + * Arguments are opposite sign; remainder is sum. + */ + + TclBNInitBignumFromWideInt(&big1, w1); + mp_add(&big2, &big1, &big2); + mp_clear(&big1); + BIG_RESULT(&big2); + } + + /* + * Arguments are same sign; remainder is first operand. + */ + mp_clear(&big2); + return NULL; + } +#endif + Tcl_GetBignumFromObj(NULL, valuePtr, &big1); + Tcl_GetBignumFromObj(NULL, value2Ptr, &big2); + mp_init(&bigResult); + mp_init(&bigRemainder); + mp_div(&big1, &big2, &bigResult, &bigRemainder); + if (!mp_iszero(&bigRemainder) && (bigRemainder.sign != big2.sign)) { /* - * Clear all expansions. + * Convert to Tcl's integer division rules. */ - while (expandNestList) { - Tcl_Obj *objPtr = expandNestList->internalRep.twoPtrValue.ptr2; - TclDecrRefCount(expandNestList); - expandNestList = objPtr; + mp_sub_d(&bigResult, 1, &bigResult); + mp_add(&bigRemainder, &big2, &bigRemainder); + } + mp_copy(&bigRemainder, &bigResult); + mp_clear(&bigRemainder); + mp_clear(&big1); + mp_clear(&big2); + BIG_RESULT(&bigResult); + + case INST_LSHIFT: + case INST_RSHIFT: { + /* + * Reject negative shift argument. + */ + + switch (type2) { + case TCL_NUMBER_LONG: + invalid = (*((const long *)ptr2) < 0L); + break; +#ifndef TCL_WIDE_INT_IS_LONG + case TCL_NUMBER_WIDE: + invalid = (*((const Tcl_WideInt *)ptr2) < (Tcl_WideInt)0); + break; +#endif + case TCL_NUMBER_BIG: + Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2); + invalid = (mp_cmp_d(&big2, 0) == MP_LT); + mp_clear(&big2); + break; + default: + /* Unused, here to silence compiler warning */ + invalid = 0; + } + if (invalid) { + Tcl_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_LONG) && (*((const long *)ptr1) == (long)0)) { + return constants[0]; + } + + if (opcode == INST_LSHIFT) { + /* + * Large left shifts create integer overflow. + * + * BEWARE! Can't use Tcl_GetIntFromObj() here because that + * converts values in the (unsigned) range to their signed int + * counterparts, leading to incorrect results. + */ + + if ((type2 != TCL_NUMBER_LONG) + || (*((const long *)ptr2) > (long) INT_MAX)) { + /* + * Technically, we could hold the value (1 << (INT_MAX+1)) in + * an mp_int, but since we're using mp_mul_2d() to do the + * work, and it takes only an int argument, that's a good + * place to draw the line. + */ + + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "integer value too large to represent", -1)); + return GENERAL_ARITHMETIC_ERROR; + } + shift = (int)(*((const long *)ptr2)); + + /* + * Handle shifts within the native wide range. + */ + + if ((type1 != TCL_NUMBER_BIG) + && ((size_t)shift < CHAR_BIT*sizeof(Tcl_WideInt))) { + TclGetWideIntFromObj(NULL, valuePtr, &w1); + if (!((w1>0 ? w1 : ~w1) + & -(((Tcl_WideInt)1) + << (CHAR_BIT*sizeof(Tcl_WideInt) - 1 - shift)))) { + WIDE_RESULT(w1 << shift); + } + } + } else { + /* + * Quickly force large right shifts to 0 or -1. + */ + + if ((type2 != TCL_NUMBER_LONG) + || (*(const long *)ptr2 > INT_MAX)) { + /* + * Again, technically, the value to be shifted could be an + * mp_int so huge that a right shift by (INT_MAX+1) bits could + * not take us to the result of 0 or -1, but since we're using + * mp_div_2d to do the work, and it takes only an int + * argument, we draw the line there. + */ + + switch (type1) { + case TCL_NUMBER_LONG: + zero = (*(const long *)ptr1 > 0L); + break; +#ifndef TCL_WIDE_INT_IS_LONG + case TCL_NUMBER_WIDE: + zero = (*(const Tcl_WideInt *)ptr1 > (Tcl_WideInt)0); + break; +#endif + case TCL_NUMBER_BIG: + Tcl_TakeBignumFromObj(NULL, valuePtr, &big1); + zero = (mp_cmp_d(&big1, 0) == MP_GT); + mp_clear(&big1); + break; + default: + /* Unused, here to silence compiler warning. */ + zero = 0; + } + if (zero) { + return constants[0]; + } + LONG_RESULT(-1); } - if (tosPtr < initTosPtr) { - fprintf(stderr, "\nTclExecuteByteCode: abnormal return at pc %u: stack top %d < entry stack top %d\n", - (unsigned int)(pc - codePtr->codeStart), - (unsigned int) (tosPtr - eePtr->stackPtr), - (unsigned int) initStackTop); - Tcl_Panic("TclExecuteByteCode execution failure: end stack top < start stack top"); + shift = (int)(*(const long *)ptr2); + +#ifndef TCL_WIDE_INT_IS_LONG + /* + * Handle shifts within the native wide range. + */ + + if (type1 == TCL_NUMBER_WIDE) { + w1 = *(const Tcl_WideInt *)ptr1; + if ((size_t)shift >= CHAR_BIT*sizeof(Tcl_WideInt)) { + if (w1 >= (Tcl_WideInt)0) { + return constants[0]; + } + LONG_RESULT(-1); + } + WIDE_RESULT(w1 >> shift); } - eePtr->tosPtr = initTosPtr - codePtr->maxExceptDepth; +#endif } + + Tcl_TakeBignumFromObj(NULL, valuePtr, &big1); + + mp_init(&bigResult); + if (opcode == INST_LSHIFT) { + mp_mul_2d(&big1, shift, &bigResult); + } else { + mp_init(&bigRemainder); + mp_div_2d(&big1, shift, &bigResult, &bigRemainder); + if (mp_cmp_d(&bigRemainder, 0) == MP_LT) { + /* + * Convert to Tcl's integer division rules. + */ + + mp_sub_d(&bigResult, 1, &bigResult); + } + mp_clear(&bigRemainder); + } + mp_clear(&big1); + BIG_RESULT(&bigResult); + } + + case INST_BITOR: + case INST_BITXOR: + case INST_BITAND: + if ((type1 == TCL_NUMBER_BIG) || (type2 == TCL_NUMBER_BIG)) { + mp_int *First, *Second; + + Tcl_TakeBignumFromObj(NULL, valuePtr, &big1); + Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2); + + /* + * Count how many positive arguments we have. If only one of the + * arguments is negative, store it in 'Second'. + */ + + if (mp_cmp_d(&big1, 0) != MP_LT) { + numPos = 1 + (mp_cmp_d(&big2, 0) != MP_LT); + First = &big1; + Second = &big2; + } else { + First = &big2; + Second = &big1; + numPos = (mp_cmp_d(First, 0) != MP_LT); + } + mp_init(&bigResult); + + switch (opcode) { + case INST_BITAND: + switch (numPos) { + case 2: + /* + * Both arguments positive, base case. + */ + + mp_and(First, Second, &bigResult); + break; + case 1: + /* + * First is positive; second negative: + * P & N = P & ~~N = P&~(-N-1) = P & (P ^ (-N-1)) + */ + + mp_neg(Second, Second); + mp_sub_d(Second, 1, Second); + mp_xor(First, Second, &bigResult); + mp_and(First, &bigResult, &bigResult); + break; + case 0: + /* + * Both arguments negative: + * a & b = ~ (~a | ~b) = -(-a-1|-b-1)-1 + */ + + mp_neg(First, First); + mp_sub_d(First, 1, First); + mp_neg(Second, Second); + mp_sub_d(Second, 1, Second); + mp_or(First, Second, &bigResult); + mp_neg(&bigResult, &bigResult); + mp_sub_d(&bigResult, 1, &bigResult); + break; + } + break; + + case INST_BITOR: + switch (numPos) { + case 2: + /* + * Both arguments positive, base case. + */ + + mp_or(First, Second, &bigResult); + break; + case 1: + /* + * First is positive; second negative: + * N|P = ~(~N&~P) = ~((-N-1)&~P) = -((-N-1)&((-N-1)^P))-1 + */ + + mp_neg(Second, Second); + mp_sub_d(Second, 1, Second); + mp_xor(First, Second, &bigResult); + mp_and(Second, &bigResult, &bigResult); + mp_neg(&bigResult, &bigResult); + mp_sub_d(&bigResult, 1, &bigResult); + break; + case 0: + /* + * Both arguments negative: + * a | b = ~ (~a & ~b) = -(-a-1&-b-1)-1 + */ + + mp_neg(First, First); + mp_sub_d(First, 1, First); + mp_neg(Second, Second); + mp_sub_d(Second, 1, Second); + mp_and(First, Second, &bigResult); + mp_neg(&bigResult, &bigResult); + mp_sub_d(&bigResult, 1, &bigResult); + break; + } + break; + + case INST_BITXOR: + switch (numPos) { + case 2: + /* + * Both arguments positive, base case. + */ + + mp_xor(First, Second, &bigResult); + break; + case 1: + /* + * First is positive; second negative: + * P^N = ~(P^~N) = -(P^(-N-1))-1 + */ + + mp_neg(Second, Second); + mp_sub_d(Second, 1, Second); + mp_xor(First, Second, &bigResult); + mp_neg(&bigResult, &bigResult); + mp_sub_d(&bigResult, 1, &bigResult); + break; + case 0: + /* + * Both arguments negative: + * a ^ b = (~a ^ ~b) = (-a-1^-b-1) + */ + + mp_neg(First, First); + mp_sub_d(First, 1, First); + mp_neg(Second, Second); + mp_sub_d(Second, 1, Second); + mp_xor(First, Second, &bigResult); + break; + } + break; + } + + mp_clear(&big1); + mp_clear(&big2); + BIG_RESULT(&bigResult); + } + +#ifndef TCL_WIDE_INT_IS_LONG + if ((type1 == TCL_NUMBER_WIDE) || (type2 == TCL_NUMBER_WIDE)) { + TclGetWideIntFromObj(NULL, valuePtr, &w1); + TclGetWideIntFromObj(NULL, value2Ptr, &w2); + + switch (opcode) { + case INST_BITAND: + wResult = w1 & w2; + break; + case INST_BITOR: + wResult = w1 | w2; + break; + case INST_BITXOR: + wResult = w1 ^ w2; + break; + default: + /* Unused, here to silence compiler warning. */ + wResult = 0; + } + WIDE_RESULT(wResult); + } +#endif + l1 = *((const long *)ptr1); + l2 = *((const long *)ptr2); + + switch (opcode) { + case INST_BITAND: + lResult = l1 & l2; + break; + case INST_BITOR: + lResult = l1 | l2; + break; + case INST_BITXOR: + lResult = l1 ^ l2; + break; + default: + /* Unused, here to silence compiler warning. */ + lResult = 0; + } + LONG_RESULT(lResult); + + case INST_EXPON: { + int oddExponent = 0, negativeExponent = 0; + unsigned short base; + + if ((type1 == TCL_NUMBER_DOUBLE) || (type2 == TCL_NUMBER_DOUBLE)) { + Tcl_GetDoubleFromObj(NULL, valuePtr, &d1); + Tcl_GetDoubleFromObj(NULL, value2Ptr, &d2); + + if (d1==0.0 && d2<0.0) { + return EXPONENT_OF_ZERO; + } + dResult = pow(d1, d2); + goto doubleResult; + } + l1 = l2 = 0; + if (type2 == TCL_NUMBER_LONG) { + l2 = *((const long *) ptr2); + if (l2 == 0) { + /* + * Anything to the zero power is 1. + */ + + return constants[1]; + } else if (l2 == 1) { + /* + * Anything to the first power is itself + */ + + return NULL; + } + } + + switch (type2) { + case TCL_NUMBER_LONG: + negativeExponent = (l2 < 0); + oddExponent = (int) (l2 & 1); + break; +#ifndef TCL_WIDE_INT_IS_LONG + case TCL_NUMBER_WIDE: + w2 = *((const Tcl_WideInt *)ptr2); + negativeExponent = (w2 < 0); + oddExponent = (int) (w2 & (Tcl_WideInt)1); + break; +#endif + case TCL_NUMBER_BIG: + Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2); + negativeExponent = (mp_cmp_d(&big2, 0) == MP_LT); + mp_mod_2d(&big2, 1, &big2); + oddExponent = !mp_iszero(&big2); + mp_clear(&big2); + break; + } + + if (type1 == TCL_NUMBER_LONG) { + l1 = *((const long *)ptr1); + } + if (negativeExponent) { + if (type1 == TCL_NUMBER_LONG) { + switch (l1) { + case 0: + /* + * Zero to a negative power is div by zero error. + */ + + return EXPONENT_OF_ZERO; + case -1: + if (oddExponent) { + LONG_RESULT(-1); + } + /* fallthrough */ + case 1: + /* + * 1 to any power is 1. + */ + + return constants[1]; + } + } + + /* + * Integers with magnitude greater than 1 raise to a negative + * power yield the answer zero (see TIP 123). + */ + + return constants[0]; + } + + if (type1 == TCL_NUMBER_LONG) { + switch (l1) { + case 0: + /* + * Zero to a positive power is zero. + */ + + return constants[0]; + case 1: + /* + * 1 to any power is 1. + */ + + return constants[1]; + case -1: + if (!oddExponent) { + return constants[1]; + } + LONG_RESULT(-1); + } + } + + /* + * We refuse to accept exponent arguments that exceed one mp_digit + * which means the max exponent value is 2**28-1 = 0x0fffffff = + * 268435455, which fits into a signed 32 bit int which is within the + * range of the long int type. This means any numeric Tcl_Obj value + * not using TCL_NUMBER_LONG type must hold a value larger than we + * accept. + */ + + if (type2 != TCL_NUMBER_LONG) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "exponent too large", -1)); + return GENERAL_ARITHMETIC_ERROR; + } + + if (type1 == TCL_NUMBER_LONG) { + if (l1 == 2) { + /* + * Reduce small powers of 2 to shifts. + */ + + if ((unsigned long) l2 < CHAR_BIT * sizeof(long) - 1) { + LONG_RESULT(1L << l2); + } +#if !defined(TCL_WIDE_INT_IS_LONG) + if ((unsigned long)l2 < CHAR_BIT*sizeof(Tcl_WideInt) - 1) { + WIDE_RESULT(((Tcl_WideInt) 1) << l2); + } +#endif + goto overflowExpon; + } + if (l1 == -2) { + int signum = oddExponent ? -1 : 1; + + /* + * Reduce small powers of 2 to shifts. + */ + + if ((unsigned long) l2 < CHAR_BIT * sizeof(long) - 1) { + LONG_RESULT(signum * (1L << l2)); + } +#if !defined(TCL_WIDE_INT_IS_LONG) + if ((unsigned long)l2 < CHAR_BIT*sizeof(Tcl_WideInt) - 1){ + WIDE_RESULT(signum * (((Tcl_WideInt) 1) << l2)); + } +#endif + goto overflowExpon; + } +#if (LONG_MAX == 0x7fffffff) + if (l2 - 2 < (long)MaxBase32Size + && l1 <= MaxBase32[l2 - 2] + && l1 >= -MaxBase32[l2 - 2]) { + /* + * Small powers of 32-bit integers. + */ + + lResult = l1 * l1; /* b**2 */ + switch (l2) { + case 2: + break; + case 3: + lResult *= l1; /* b**3 */ + break; + case 4: + lResult *= lResult; /* b**4 */ + break; + case 5: + lResult *= lResult; /* b**4 */ + lResult *= l1; /* b**5 */ + break; + case 6: + lResult *= l1; /* b**3 */ + lResult *= lResult; /* b**6 */ + break; + case 7: + lResult *= l1; /* b**3 */ + lResult *= lResult; /* b**6 */ + lResult *= l1; /* b**7 */ + break; + case 8: + lResult *= lResult; /* b**4 */ + lResult *= lResult; /* b**8 */ + break; + } + LONG_RESULT(lResult); + } + + if (l1 - 3 >= 0 && l1 -2 < (long)Exp32IndexSize + && l2 - 2 < (long)(Exp32ValueSize + MaxBase32Size)) { + base = Exp32Index[l1 - 3] + + (unsigned short) (l2 - 2 - MaxBase32Size); + if (base < Exp32Index[l1 - 2]) { + /* + * 32-bit number raised to intermediate power, done by + * table lookup. + */ + + LONG_RESULT(Exp32Value[base]); + } + } + if (-l1 - 3 >= 0 && -l1 - 2 < (long)Exp32IndexSize + && l2 - 2 < (long)(Exp32ValueSize + MaxBase32Size)) { + base = Exp32Index[-l1 - 3] + + (unsigned short) (l2 - 2 - MaxBase32Size); + if (base < Exp32Index[-l1 - 2]) { + /* + * 32-bit number raised to intermediate power, done by + * table lookup. + */ + + lResult = (oddExponent) ? + -Exp32Value[base] : Exp32Value[base]; + LONG_RESULT(lResult); + } + } +#endif + } +#if (LONG_MAX > 0x7fffffff) || !defined(TCL_WIDE_INT_IS_LONG) + if (type1 == TCL_NUMBER_LONG) { + w1 = l1; +#ifndef TCL_WIDE_INT_IS_LONG + } else if (type1 == TCL_NUMBER_WIDE) { + w1 = *((const Tcl_WideInt *) ptr1); +#endif + } else { + goto overflowExpon; + } + if (l2 - 2 < (long)MaxBase64Size + && w1 <= MaxBase64[l2 - 2] + && w1 >= -MaxBase64[l2 - 2]) { + /* + * Small powers of integers whose result is wide. + */ + + wResult = w1 * w1; /* b**2 */ + switch (l2) { + case 2: + break; + case 3: + wResult *= l1; /* b**3 */ + break; + case 4: + wResult *= wResult; /* b**4 */ + break; + case 5: + wResult *= wResult; /* b**4 */ + wResult *= w1; /* b**5 */ + break; + case 6: + wResult *= w1; /* b**3 */ + wResult *= wResult; /* b**6 */ + break; + case 7: + wResult *= w1; /* b**3 */ + wResult *= wResult; /* b**6 */ + wResult *= w1; /* b**7 */ + break; + case 8: + wResult *= wResult; /* b**4 */ + wResult *= wResult; /* b**8 */ + break; + case 9: + wResult *= wResult; /* b**4 */ + wResult *= wResult; /* b**8 */ + wResult *= w1; /* b**9 */ + break; + case 10: + wResult *= wResult; /* b**4 */ + wResult *= w1; /* b**5 */ + wResult *= wResult; /* b**10 */ + break; + case 11: + wResult *= wResult; /* b**4 */ + wResult *= w1; /* b**5 */ + wResult *= wResult; /* b**10 */ + wResult *= w1; /* b**11 */ + break; + case 12: + wResult *= w1; /* b**3 */ + wResult *= wResult; /* b**6 */ + wResult *= wResult; /* b**12 */ + break; + case 13: + wResult *= w1; /* b**3 */ + wResult *= wResult; /* b**6 */ + wResult *= wResult; /* b**12 */ + wResult *= w1; /* b**13 */ + break; + case 14: + wResult *= w1; /* b**3 */ + wResult *= wResult; /* b**6 */ + wResult *= w1; /* b**7 */ + wResult *= wResult; /* b**14 */ + break; + case 15: + wResult *= w1; /* b**3 */ + wResult *= wResult; /* b**6 */ + wResult *= w1; /* b**7 */ + wResult *= wResult; /* b**14 */ + wResult *= w1; /* b**15 */ + break; + case 16: + wResult *= wResult; /* b**4 */ + wResult *= wResult; /* b**8 */ + wResult *= wResult; /* b**16 */ + break; + } + WIDE_RESULT(wResult); + } + + /* + * Handle cases of powers > 16 that still fit in a 64-bit word by + * doing table lookup. + */ + + if (w1 - 3 >= 0 && w1 - 2 < (long)Exp64IndexSize + && l2 - 2 < (long)(Exp64ValueSize + MaxBase64Size)) { + base = Exp64Index[w1 - 3] + + (unsigned short) (l2 - 2 - MaxBase64Size); + if (base < Exp64Index[w1 - 2]) { + /* + * 64-bit number raised to intermediate power, done by + * table lookup. + */ + + WIDE_RESULT(Exp64Value[base]); + } + } + + if (-w1 - 3 >= 0 && -w1 - 2 < (long)Exp64IndexSize + && l2 - 2 < (long)(Exp64ValueSize + MaxBase64Size)) { + base = Exp64Index[-w1 - 3] + + (unsigned short) (l2 - 2 - MaxBase64Size); + if (base < Exp64Index[-w1 - 2]) { + /* + * 64-bit number raised to intermediate power, done by + * table lookup. + */ + + wResult = oddExponent ? -Exp64Value[base] : Exp64Value[base]; + WIDE_RESULT(wResult); + } + } +#endif + + overflowExpon: + Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2); + if (big2.used > 1) { + mp_clear(&big2); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "exponent too large", -1)); + return GENERAL_ARITHMETIC_ERROR; + } + Tcl_TakeBignumFromObj(NULL, valuePtr, &big1); + mp_init(&bigResult); + mp_expt_d(&big1, big2.dp[0], &bigResult); + mp_clear(&big1); + mp_clear(&big2); + BIG_RESULT(&bigResult); + } + + case INST_ADD: + case INST_SUB: + case INST_MULT: + case INST_DIV: + if ((type1 == TCL_NUMBER_DOUBLE) || (type2 == TCL_NUMBER_DOUBLE)) { + /* + * At least one of the values is floating-point, so perform + * floating point calculations. + */ + + Tcl_GetDoubleFromObj(NULL, valuePtr, &d1); + Tcl_GetDoubleFromObj(NULL, value2Ptr, &d2); + + switch (opcode) { + case INST_ADD: + dResult = d1 + d2; + break; + case INST_SUB: + dResult = d1 - d2; + break; + case INST_MULT: + dResult = d1 * d2; + break; + case INST_DIV: +#ifndef IEEE_FLOATING_POINT + if (d2 == 0.0) { + return DIVIDED_BY_ZERO; + } +#endif + /* + * We presume that we are running with zero-divide unmasked if + * we're on an IEEE box. Otherwise, this statement might cause + * demons to fly out our noses. + */ + + dResult = d1 / d2; + break; + default: + /* Unused, here to silence compiler warning. */ + dResult = 0; + } + + doubleResult: +#ifndef ACCEPT_NAN + /* + * Check now for IEEE floating-point error. + */ + + if (TclIsNaN(dResult)) { + TclExprFloatError(interp, dResult); + return GENERAL_ARITHMETIC_ERROR; + } +#endif + DOUBLE_RESULT(dResult); + } + if ((type1 != TCL_NUMBER_BIG) && (type2 != TCL_NUMBER_BIG)) { + TclGetWideIntFromObj(NULL, valuePtr, &w1); + TclGetWideIntFromObj(NULL, value2Ptr, &w2); + + switch (opcode) { + case INST_ADD: + wResult = w1 + w2; +#ifndef TCL_WIDE_INT_IS_LONG + if ((type1 == TCL_NUMBER_WIDE) || (type2 == TCL_NUMBER_WIDE)) +#endif + { + /* + * Check for overflow. + */ + + if (Overflowing(w1, w2, wResult)) { + goto overflowBasic; + } + } + break; + + case INST_SUB: + wResult = w1 - w2; +#ifndef TCL_WIDE_INT_IS_LONG + if ((type1 == TCL_NUMBER_WIDE) || (type2 == TCL_NUMBER_WIDE)) +#endif + { + /* + * Must check for overflow. The macro tests for overflows + * in sums by looking at the sign bits. As we have a + * subtraction here, we are adding -w2. As -w2 could in + * turn overflow, we test with ~w2 instead: it has the + * opposite sign bit to w2 so it does the job. Note that + * the only "bad" case (w2==0) is irrelevant for this + * macro, as in that case w1 and wResult have the same + * sign and there is no overflow anyway. + */ + + if (Overflowing(w1, ~w2, wResult)) { + goto overflowBasic; + } + } + break; + + case INST_MULT: + if ((type1 != TCL_NUMBER_LONG) || (type2 != TCL_NUMBER_LONG) + || (sizeof(Tcl_WideInt) < 2*sizeof(long))) { + goto overflowBasic; + } + wResult = w1 * w2; + break; + + case INST_DIV: + if (w2 == 0) { + return DIVIDED_BY_ZERO; + } + + /* + * Need a bignum to represent (LLONG_MIN / -1) + */ + + if ((w1 == LLONG_MIN) && (w2 == -1)) { + goto overflowBasic; + } + wResult = w1 / w2; + + /* + * Force Tcl's integer division rules. + * TODO: examine for logic simplification + */ + + if (((wResult < 0) || ((wResult == 0) && + ((w1 < 0 && w2 > 0) || (w1 > 0 && w2 < 0)))) && + (wResult*w2 != w1)) { + wResult -= 1; + } + break; + + default: + /* + * Unused, here to silence compiler warning. + */ + + wResult = 0; + } + + WIDE_RESULT(wResult); + } + + overflowBasic: + Tcl_TakeBignumFromObj(NULL, valuePtr, &big1); + Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2); + mp_init(&bigResult); + switch (opcode) { + case INST_ADD: + mp_add(&big1, &big2, &bigResult); + break; + case INST_SUB: + mp_sub(&big1, &big2, &bigResult); + break; + case INST_MULT: + mp_mul(&big1, &big2, &bigResult); + break; + case INST_DIV: + if (mp_iszero(&big2)) { + mp_clear(&big1); + mp_clear(&big2); + mp_clear(&bigResult); + return DIVIDED_BY_ZERO; + } + mp_init(&bigRemainder); + mp_div(&big1, &big2, &bigResult, &bigRemainder); + /* TODO: internals intrusion */ + if (!mp_iszero(&bigRemainder) + && (bigRemainder.sign != big2.sign)) { + /* + * Convert to Tcl's integer division rules. + */ + + mp_sub_d(&bigResult, 1, &bigResult); + mp_add(&bigRemainder, &big2, &bigRemainder); + } + mp_clear(&bigRemainder); + break; + } + mp_clear(&big1); + mp_clear(&big2); + BIG_RESULT(&bigResult); + } + + Tcl_Panic("unexpected opcode"); + return NULL; +} + +static Tcl_Obj * +ExecuteExtendedUnaryMathOp( + int opcode, /* What operation to perform. */ + Tcl_Obj *valuePtr) /* The operand on the stack. */ +{ + ClientData ptr; + int type; + Tcl_WideInt w; + mp_int big; + Tcl_Obj *objResultPtr; + + (void) GetNumberFromObj(NULL, valuePtr, &ptr, &type); + + switch (opcode) { + case INST_BITNOT: +#ifndef TCL_WIDE_INT_IS_LONG + if (type == TCL_NUMBER_WIDE) { + w = *((const Tcl_WideInt *) ptr); + WIDE_RESULT(~w); + } +#endif + Tcl_TakeBignumFromObj(NULL, valuePtr, &big); + /* ~a = - a - 1 */ + mp_neg(&big, &big); + mp_sub_d(&big, 1, &big); + BIG_RESULT(&big); + case INST_UMINUS: + switch (type) { + case TCL_NUMBER_DOUBLE: + DOUBLE_RESULT(-(*((const double *) ptr))); + case TCL_NUMBER_LONG: + w = (Tcl_WideInt) (*((const long *) ptr)); + if (w != LLONG_MIN) { + WIDE_RESULT(-w); + } + TclBNInitBignumFromLong(&big, *(const long *) ptr); + break; +#ifndef TCL_WIDE_INT_IS_LONG + case TCL_NUMBER_WIDE: + w = *((const Tcl_WideInt *) ptr); + if (w != LLONG_MIN) { + WIDE_RESULT(-w); + } + TclBNInitBignumFromWideInt(&big, w); + break; +#endif + default: + Tcl_TakeBignumFromObj(NULL, valuePtr, &big); + } + mp_neg(&big, &big); + BIG_RESULT(&big); + } + + Tcl_Panic("unexpected opcode"); + return NULL; +} +#undef LONG_RESULT +#undef WIDE_RESULT +#undef BIG_RESULT +#undef DOUBLE_RESULT + +/* + *---------------------------------------------------------------------- + * + * CompareTwoNumbers -- + * + * This function compares a pair of numbers in Tcl_Objs. Each argument + * must already be known to be numeric and not NaN. + * + * Results: + * One of MP_LT, MP_EQ or MP_GT, depending on whether valuePtr is less + * than, equal to, or greater than value2Ptr (respectively). + * + * Side effects: + * None, provided both values are numeric. + * + *---------------------------------------------------------------------- + */ + +int +TclCompareTwoNumbers( + Tcl_Obj *valuePtr, + Tcl_Obj *value2Ptr) +{ + int type1, type2, compare; + ClientData ptr1, ptr2; + mp_int big1, big2; + double d1, d2, tmp; + long l1, l2; +#ifndef TCL_WIDE_INT_IS_LONG + Tcl_WideInt w1, w2; +#endif + + (void) GetNumberFromObj(NULL, valuePtr, &ptr1, &type1); + (void) GetNumberFromObj(NULL, value2Ptr, &ptr2, &type2); + + switch (type1) { + case TCL_NUMBER_LONG: + l1 = *((const long *)ptr1); + switch (type2) { + case TCL_NUMBER_LONG: + l2 = *((const long *)ptr2); + longCompare: + return (l1 < l2) ? MP_LT : ((l1 > l2) ? MP_GT : MP_EQ); +#ifndef TCL_WIDE_INT_IS_LONG + case TCL_NUMBER_WIDE: + w2 = *((const Tcl_WideInt *)ptr2); + w1 = (Tcl_WideInt)l1; + goto wideCompare; +#endif + case TCL_NUMBER_DOUBLE: + d2 = *((const double *)ptr2); + d1 = (double) l1; + + /* + * If the double has a fractional part, or if the long can be + * converted to double without loss of precision, then compare as + * doubles. + */ + + if (DBL_MANT_DIG > CHAR_BIT*sizeof(long) || l1 == (long) d1 + || modf(d2, &tmp) != 0.0) { + goto doubleCompare; + } + + /* + * Otherwise, to make comparision based on full precision, need to + * convert the double to a suitably sized integer. + * + * Need this to get comparsions like + * expr 20000000000000003 < 20000000000000004.0 + * right. Converting the first argument to double will yield two + * double values that are equivalent within double precision. + * Converting the double to an integer gets done exactly, then + * integer comparison can tell the difference. + */ + + if (d2 < (double)LONG_MIN) { + return MP_GT; + } + if (d2 > (double)LONG_MAX) { + return MP_LT; + } + l2 = (long) d2; + goto longCompare; + case TCL_NUMBER_BIG: + Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2); + if (mp_cmp_d(&big2, 0) == MP_LT) { + compare = MP_GT; + } else { + compare = MP_LT; + } + mp_clear(&big2); + return compare; + } + +#ifndef TCL_WIDE_INT_IS_LONG + case TCL_NUMBER_WIDE: + w1 = *((const Tcl_WideInt *)ptr1); + switch (type2) { + case TCL_NUMBER_WIDE: + w2 = *((const Tcl_WideInt *)ptr2); + wideCompare: + return (w1 < w2) ? MP_LT : ((w1 > w2) ? MP_GT : MP_EQ); + case TCL_NUMBER_LONG: + l2 = *((const long *)ptr2); + w2 = (Tcl_WideInt)l2; + goto wideCompare; + case TCL_NUMBER_DOUBLE: + d2 = *((const double *)ptr2); + d1 = (double) w1; + if (DBL_MANT_DIG > CHAR_BIT*sizeof(Tcl_WideInt) + || w1 == (Tcl_WideInt) d1 || modf(d2, &tmp) != 0.0) { + goto doubleCompare; + } + if (d2 < (double)LLONG_MIN) { + return MP_GT; + } + if (d2 > (double)LLONG_MAX) { + return MP_LT; + } + w2 = (Tcl_WideInt) d2; + goto wideCompare; + case TCL_NUMBER_BIG: + Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2); + if (mp_cmp_d(&big2, 0) == MP_LT) { + compare = MP_GT; + } else { + compare = MP_LT; + } + mp_clear(&big2); + return compare; + } +#endif + + case TCL_NUMBER_DOUBLE: + d1 = *((const double *)ptr1); + switch (type2) { + case TCL_NUMBER_DOUBLE: + d2 = *((const double *)ptr2); + doubleCompare: + return (d1 < d2) ? MP_LT : ((d1 > d2) ? MP_GT : MP_EQ); + case TCL_NUMBER_LONG: + l2 = *((const long *)ptr2); + d2 = (double) l2; + if (DBL_MANT_DIG > CHAR_BIT*sizeof(long) || l2 == (long) d2 + || modf(d1, &tmp) != 0.0) { + goto doubleCompare; + } + if (d1 < (double)LONG_MIN) { + return MP_LT; + } + if (d1 > (double)LONG_MAX) { + return MP_GT; + } + l1 = (long) d1; + goto longCompare; +#ifndef TCL_WIDE_INT_IS_LONG + case TCL_NUMBER_WIDE: + w2 = *((const Tcl_WideInt *)ptr2); + d2 = (double) w2; + if (DBL_MANT_DIG > CHAR_BIT*sizeof(Tcl_WideInt) + || w2 == (Tcl_WideInt) d2 || modf(d1, &tmp) != 0.0) { + goto doubleCompare; + } + if (d1 < (double)LLONG_MIN) { + return MP_LT; + } + if (d1 > (double)LLONG_MAX) { + return MP_GT; + } + w1 = (Tcl_WideInt) d1; + goto wideCompare; +#endif + case TCL_NUMBER_BIG: + if (TclIsInfinite(d1)) { + return (d1 > 0.0) ? MP_GT : MP_LT; + } + Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2); + if ((d1 < (double)LONG_MAX) && (d1 > (double)LONG_MIN)) { + if (mp_cmp_d(&big2, 0) == MP_LT) { + compare = MP_GT; + } else { + compare = MP_LT; + } + mp_clear(&big2); + return compare; + } + if (DBL_MANT_DIG > CHAR_BIT*sizeof(long) + && modf(d1, &tmp) != 0.0) { + d2 = TclBignumToDouble(&big2); + mp_clear(&big2); + goto doubleCompare; + } + Tcl_InitBignumFromDouble(NULL, d1, &big1); + goto bigCompare; + } + + case TCL_NUMBER_BIG: + Tcl_TakeBignumFromObj(NULL, valuePtr, &big1); + switch (type2) { +#ifndef TCL_WIDE_INT_IS_LONG + case TCL_NUMBER_WIDE: +#endif + case TCL_NUMBER_LONG: + compare = mp_cmp_d(&big1, 0); + mp_clear(&big1); + return compare; + case TCL_NUMBER_DOUBLE: + d2 = *((const double *)ptr2); + if (TclIsInfinite(d2)) { + compare = (d2 > 0.0) ? MP_LT : MP_GT; + mp_clear(&big1); + return compare; + } + if ((d2 < (double)LONG_MAX) && (d2 > (double)LONG_MIN)) { + compare = mp_cmp_d(&big1, 0); + mp_clear(&big1); + return compare; + } + if (DBL_MANT_DIG > CHAR_BIT*sizeof(long) + && modf(d2, &tmp) != 0.0) { + d1 = TclBignumToDouble(&big1); + mp_clear(&big1); + goto doubleCompare; + } + Tcl_InitBignumFromDouble(NULL, d2, &big2); + goto bigCompare; + case TCL_NUMBER_BIG: + Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2); + bigCompare: + compare = mp_cmp(&big1, &big2); + mp_clear(&big1); + mp_clear(&big2); + return compare; + } + default: + Tcl_Panic("unexpected number type"); + return TCL_ERROR; } - return result; -#undef iPtr } #ifdef TCL_COMPILE_DEBUG @@ -6409,7 +9516,7 @@ TclExecuteByteCode( * PrintByteCodeInfo -- * * This procedure prints a summary about a bytecode object to stdout. It - * is called by TclExecuteByteCode when starting to execute the bytecode + * is called by TclNRExecuteByteCode when starting to execute the bytecode * object if tclTraceExec has the value 2 or more. * * Results: @@ -6429,9 +9536,8 @@ PrintByteCodeInfo( Proc *procPtr = codePtr->procPtr; Interp *iPtr = (Interp *) *codePtr->interpHandle; - fprintf(stdout, "\nExecuting ByteCode 0x%x, refCt %u, epoch %u, interp 0x%x (epoch %u)\n", - (unsigned int) codePtr, codePtr->refCount, - codePtr->compileEpoch, (unsigned int) iPtr, + 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: "); @@ -6443,25 +9549,25 @@ PrintByteCodeInfo( codePtr->numAuxDataItems, codePtr->maxStackDepth, #ifdef TCL_COMPILE_STATS codePtr->numSrcBytes? - ((float)codePtr->structureSize)/codePtr->numSrcBytes : + ((float)codePtr->structureSize)/codePtr->numSrcBytes : #endif 0.0); #ifdef TCL_COMPILE_STATS - fprintf(stdout, " Code %d = header %d+inst %d+litObj %d+exc %d+aux %d+cmdMap %d\n", - codePtr->structureSize, - (sizeof(ByteCode) - (sizeof(size_t) + sizeof(Tcl_Time))), + fprintf(stdout, " Code %lu = header %lu+inst %d+litObj %lu+exc %lu+aux %lu+cmdMap %d\n", + (unsigned long) codePtr->structureSize, + (unsigned long) (sizeof(ByteCode)-sizeof(size_t)-sizeof(Tcl_Time)), 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) { fprintf(stdout, - " Proc 0x%x, refCt %d, args %d, compiled locals %d\n", - (unsigned int) procPtr, procPtr->refCount, - procPtr->numArgs, procPtr->numCompiledLocals); + " Proc 0x%p, refCt %d, args %d, compiled locals %d\n", + procPtr, procPtr->refCount, procPtr->numArgs, + procPtr->numCompiledLocals); } } #endif /* TCL_COMPILE_DEBUG */ @@ -6471,7 +9577,7 @@ PrintByteCodeInfo( * * ValidatePcAndStackTop -- * - * This procedure is called by TclExecuteByteCode when debugging to + * This procedure is called by TclNRExecuteByteCode when debugging to * verify that the program counter and stack top are valid during * execution. * @@ -6490,50 +9596,51 @@ static void ValidatePcAndStackTop( register ByteCode *codePtr, /* The bytecode whose summary is printed to * stdout. */ - unsigned char *pc, /* Points to first byte of a bytecode + const unsigned char *pc, /* Points to first byte of a bytecode * instruction. The program counter. */ int stackTop, /* Current stack top. Must be between * stackLowerBound and stackUpperBound * (inclusive). */ - int stackLowerBound, /* Smallest legal value for stackTop. */ int checkStack) /* 0 if the stack depth check should be * skipped. */ { - int stackUpperBound = stackLowerBound + codePtr->maxStackDepth; + int stackUpperBound = codePtr->maxStackDepth; /* Greatest legal value for stackTop. */ - unsigned int relativePc = (unsigned int) (pc - codePtr->codeStart); - unsigned int codeStart = (unsigned int) codePtr->codeStart; - unsigned int codeEnd = (unsigned int) + 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 (((unsigned int) pc < codeStart) || ((unsigned int) pc > codeEnd)) { - fprintf(stderr, "\nBad instruction pc 0x%x in TclExecuteByteCode\n", - (unsigned int) pc); - Tcl_Panic("TclExecuteByteCode execution failure: bad pc"); + if (((unsigned long) pc < codeStart) || ((unsigned long) pc > codeEnd)) { + fprintf(stderr, "\nBad instruction pc 0x%p in TclNRExecuteByteCode\n", + pc); + Tcl_Panic("TclNRExecuteByteCode execution failure: bad pc"); } - if ((unsigned int) opCode > LAST_INST_OPCODE) { - fprintf(stderr, "\nBad opcode %d at pc %u in TclExecuteByteCode\n", - (unsigned int) opCode, relativePc); - Tcl_Panic("TclExecuteByteCode execution failure: bad opcode"); + if ((unsigned) opCode > LAST_INST_OPCODE) { + fprintf(stderr, "\nBad opcode %d at pc %u in TclNRExecuteByteCode\n", + (unsigned) opCode, relativePc); + Tcl_Panic("TclNRExecuteByteCode execution failure: bad opcode"); } - if (checkStack && - ((stackTop < stackLowerBound) || (stackTop > stackUpperBound))) { + if (checkStack && + ((stackTop < 0) || (stackTop > stackUpperBound))) { int numChars; - char *cmd = GetSrcInfoForPc(pc, codePtr, &numChars); + const char *cmd = GetSrcInfoForPc(pc, codePtr, &numChars, NULL, NULL); - fprintf(stderr, "\nBad stack top %d at pc %u in TclExecuteByteCode (min %i, max %i)", - stackTop, relativePc, stackLowerBound, stackUpperBound); + fprintf(stderr, "\nBad stack top %d at pc %u in TclNRExecuteByteCode (min 0, max %i)", + stackTop, relativePc, stackUpperBound); if (cmd != NULL) { - Tcl_Obj *message = Tcl_NewStringObj("\n executing ", -1); + Tcl_Obj *message; + + TclNewLiteralStringObj(message, "\n executing "); Tcl_IncrRefCount(message); - TclAppendLimitedToObj(message, cmd, numChars, 100, NULL); + Tcl_AppendLimitedToObj(message, cmd, numChars, 100, NULL); fprintf(stderr,"%s\n", Tcl_GetString(message)); Tcl_DecrRefCount(message); } else { fprintf(stderr, "\n"); } - Tcl_Panic("TclExecuteByteCode execution failure: bad stack top"); + Tcl_Panic("TclNRExecuteByteCode execution failure: bad stack top"); } } #endif /* TCL_COMPILE_DEBUG */ @@ -6543,7 +9650,7 @@ ValidatePcAndStackTop( * * IllegalExprOperandType -- * - * Used by TclExecuteByteCode to append an error message to the interp + * Used by TclNRExecuteByteCode 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. * @@ -6560,24 +9667,26 @@ static void IllegalExprOperandType( Tcl_Interp *interp, /* Interpreter to which error information * pertains. */ - unsigned char *pc, /* Points to the instruction being executed + const 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. */ { ClientData ptr; int type; - unsigned char opcode = *pc; - CONST char *description, *operator = operatorStrings[opcode - INST_LOR]; - Tcl_Obj *msg = Tcl_NewObj(); + const unsigned char opcode = *pc; + const char *description, *operator = "unknown"; if (opcode == INST_EXPON) { operator = "**"; + } else if (opcode <= INST_STR_NEQ) { + operator = operatorStrings[opcode - INST_LOR]; } if (GetNumberFromObj(NULL, opndPtr, &ptr, &type) != TCL_OK) { int numBytes; - CONST char *bytes = Tcl_GetStringFromObj(opndPtr, &numBytes); + const char *bytes = Tcl_GetStringFromObj(opndPtr, &numBytes); + if (numBytes == 0) { description = "empty string"; } else if (TclCheckBadOctal(NULL, bytes)) { @@ -6590,19 +9699,19 @@ IllegalExprOperandType( } else if (type == TCL_NUMBER_DOUBLE) { description = "floating-point value"; } else { - /* TODO: No caller needs this. Eliminate? */ + /* TODO: No caller needs this. Eliminate? */ description = "(big) integer"; } - TclObjPrintf(NULL, msg, "can't use %s as operand of \"%s\"", - description, operator); - Tcl_SetObjResult(interp, msg); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can't use %s as operand of \"%s\"", description, operator)); + Tcl_SetErrorCode(interp, "ARITH", "DOMAIN", description, NULL); } /* *---------------------------------------------------------------------- * - * GetSrcInfoForPc -- + * TclGetSrcInfoForPc, GetSrcInfoForPc, TclGetSourceFromFrame -- * * Given a program counter value, finds the closest command in the * bytecode code unit's CmdLocation array and returns information about @@ -6618,22 +9727,111 @@ IllegalExprOperandType( * unchanged. * * Side effects: - * None. + * The CmdFrame at *cfPtr is updated. * *---------------------------------------------------------------------- */ -static char * +Tcl_Obj * +TclGetSourceFromFrame( + CmdFrame *cfPtr, + int objc, + Tcl_Obj *const objv[]) +{ + 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); + } + cfPtr->cmdObj = Tcl_NewStringObj(cfPtr->cmd, cfPtr->len); + Tcl_IncrRefCount(cfPtr->cmdObj); + } + return cfPtr->cmdObj; +} + +void +TclGetSrcInfoForPc( + CmdFrame *cfPtr) +{ + ByteCode *codePtr = (ByteCode *) cfPtr->data.tebc.codePtr; + + assert(cfPtr->type == TCL_LOCATION_BC); + + if (cfPtr->cmd == NULL) { + + cfPtr->cmd = GetSrcInfoForPc( + (unsigned char *) cfPtr->data.tebc.pc, codePtr, + &cfPtr->len, NULL, NULL); + } + + if (cfPtr->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. + */ + + ExtCmdLoc *eclPtr; + ECL *locPtr = NULL; + int srcOffset, i; + Interp *iPtr = (Interp *) *codePtr->interpHandle; + Tcl_HashEntry *hePtr = + Tcl_FindHashEntry(iPtr->lineBCPtr, codePtr); + + if (!hePtr) { + return; + } + + srcOffset = cfPtr->cmd - codePtr->source; + eclPtr = Tcl_GetHashValue(hePtr); + + for (i=0; i < eclPtr->nuloc; i++) { + if (eclPtr->loc[i].srcOffset == srcOffset) { + locPtr = eclPtr->loc+i; + break; + } + } + if (locPtr == NULL) { + Tcl_Panic("LocSearch failure"); + } + + cfPtr->line = locPtr->line; + cfPtr->nline = locPtr->nline; + cfPtr->type = eclPtr->type; + + if (eclPtr->type == TCL_LOCATION_SOURCE) { + cfPtr->data.eval.path = eclPtr->path; + Tcl_IncrRefCount(cfPtr->data.eval.path); + } + + /* + * Do not set cfPtr->data.eval.path NULL for non-SOURCE. Needed for + * cfPtr->data.tebc.codePtr. + */ + } +} + +static const char * GetSrcInfoForPc( - unsigned char *pc, /* The program counter value for which to + const unsigned char *pc, /* The program counter value for which to * return the closest command's source info. - * This points to a bytecode instruction in - * codePtr's code. */ + * This points within a bytecode instruction + * in codePtr's code. */ ByteCode *codePtr, /* The bytecode sequence in which to look up * the command source for the pc. */ - int *lengthPtr) /* If non-NULL, the location where the length + 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. */ + int *cmdIdxPtr) /* If non-NULL, the location where the index + * of the command containing the pc should + * be stored. */ { register int pcOffset = (pc - codePtr->codeStart); int numCmds = codePtr->numCommands; @@ -6643,8 +9841,10 @@ GetSrcInfoForPc( int bestDist = INT_MAX; /* Distance of pc to best cmd's start pc. */ int bestSrcOffset = -1; /* Initialized to avoid compiler warning. */ int bestSrcLength = -1; /* Initialized to avoid compiler warning. */ + int bestCmdIdx = -1; if ((pcOffset < 0) || (pcOffset >= codePtr->numCodeBytes)) { + if (pcBeg != NULL) *pcBeg = NULL; return NULL; } @@ -6656,11 +9856,11 @@ GetSrcInfoForPc( codeDeltaNext = codePtr->codeDeltaStart; codeLengthNext = codePtr->codeLengthStart; - srcDeltaNext = codePtr->srcDeltaStart; + srcDeltaNext = codePtr->srcDeltaStart; srcLengthNext = codePtr->srcLengthStart; codeOffset = srcOffset = 0; for (i = 0; i < numCmds; i++) { - if ((unsigned int) (*codeDeltaNext) == (unsigned int) 0xFF) { + if ((unsigned) *codeDeltaNext == (unsigned) 0xFF) { codeDeltaNext++; delta = TclGetInt4AtPtr(codeDeltaNext); codeDeltaNext += 4; @@ -6670,7 +9870,7 @@ GetSrcInfoForPc( } codeOffset += delta; - if ((unsigned int) (*codeLengthNext) == (unsigned int) 0xFF) { + if ((unsigned) *codeLengthNext == (unsigned) 0xFF) { codeLengthNext++; codeLen = TclGetInt4AtPtr(codeLengthNext); codeLengthNext += 4; @@ -6680,7 +9880,7 @@ GetSrcInfoForPc( } codeEnd = (codeOffset + codeLen - 1); - if ((unsigned int) (*srcDeltaNext) == (unsigned int) 0xFF) { + if ((unsigned) *srcDeltaNext == (unsigned) 0xFF) { srcDeltaNext++; delta = TclGetInt4AtPtr(srcDeltaNext); srcDeltaNext += 4; @@ -6690,7 +9890,7 @@ GetSrcInfoForPc( } srcOffset += delta; - if ((unsigned int) (*srcLengthNext) == (unsigned int) 0xFF) { + if ((unsigned) *srcLengthNext == (unsigned) 0xFF) { srcLengthNext++; srcLen = TclGetInt4AtPtr(srcLengthNext); srcLengthNext += 4; @@ -6699,18 +9899,38 @@ GetSrcInfoForPc( srcLengthNext++; } - if (codeOffset > pcOffset) { /* best cmd already found */ + if (codeOffset > pcOffset) { /* Best cmd already found */ break; - } else if (pcOffset <= codeEnd) { /* this cmd's code encloses pc */ + } + if (pcOffset <= codeEnd) { /* This cmd's code encloses pc */ int dist = (pcOffset - codeOffset); + if (dist <= bestDist) { 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; } @@ -6718,6 +9938,11 @@ GetSrcInfoForPc( if (lengthPtr != NULL) { *lengthPtr = bestSrcLength; } + + if (cmdIdxPtr != NULL) { + *cmdIdxPtr = bestCmdIdx; + } + return (codePtr->source + bestSrcOffset); } @@ -6747,7 +9972,7 @@ GetSrcInfoForPc( static ExceptionRange * GetExceptRangeForPc( - unsigned char *pc, /* The program counter value for which to + const 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. */ @@ -6755,13 +9980,13 @@ GetExceptRangeForPc( * ExceptionRanges in search. If nonzero * consider only catch ranges (and ignore any * closer loop ranges). */ - ByteCode* codePtr) /* Points to the ByteCode in which to search + ByteCode *codePtr) /* Points to the ByteCode in which to search * for the enclosing ExceptionRange. */ { ExceptionRange *rangeArrayPtr; int numRanges = codePtr->numExceptRanges; register ExceptionRange *rangePtr; - int pcOffset = (pc - codePtr->codeStart); + int pcOffset = pc - codePtr->codeStart; register int start; if (numRanges == 0) { @@ -6795,7 +10020,7 @@ GetExceptRangeForPc( * GetOpcodeName -- * * This procedure is called by the TRACE and TRACE_WITH_OBJ macros used - * in TclExecuteByteCode when debugging. It returns the name of the + * in TclNRExecuteByteCode when debugging. It returns the name of the * bytecode instruction at a specified instruction pc. * * Results: @@ -6808,9 +10033,9 @@ GetExceptRangeForPc( */ #ifdef TCL_COMPILE_DEBUG -static char * +static const char * GetOpcodeName( - unsigned char *pc) /* Points to the instruction whose name should + const unsigned char *pc) /* Points to the instruction whose name should * be returned. */ { unsigned char opCode = *pc; @@ -6842,28 +10067,28 @@ TclExprFloatError( double value) /* Value returned after error; used to * distinguish underflows from overflows. */ { - CONST char *s; + const char *s; 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, (char *) NULL); + 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, (char *) 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, (char *) NULL); + Tcl_SetErrorCode(interp, "ARITH", "OVERFLOW", s, NULL); } } else { - Tcl_Obj *objPtr = Tcl_NewObj(); - TclObjPrintf(NULL, objPtr, + Tcl_Obj *objPtr = Tcl_ObjPrintf( "unknown floating-point error, errno = %d", errno); + Tcl_SetErrorCode(interp, "ARITH", "UNKNOWN", - Tcl_GetString(objPtr), (char *) NULL); + Tcl_GetString(objPtr), NULL); Tcl_SetObjResult(interp, objPtr); } } @@ -6924,11 +10149,11 @@ EvalStatsCmd( ClientData unused, /* Unused. */ Tcl_Interp *interp, /* The current interpreter. */ int objc, /* The number of arguments. */ - Tcl_Obj *CONST objv[]) /* The argument strings. */ + Tcl_Obj *const objv[]) /* The argument strings. */ { Interp *iPtr = (Interp *) interp; - LiteralTable *globalTablePtr = &(iPtr->literalTable); - ByteCodeStats *statsPtr = &(iPtr->stats); + LiteralTable *globalTablePtr = &iPtr->literalTable; + ByteCodeStats *statsPtr = &iPtr->stats; double totalCodeBytes, currentCodeBytes; double totalLiteralBytes, currentLiteralBytes; double objBytesIfUnshared, strBytesIfUnshared, sharingBytesSaved; @@ -6940,6 +10165,12 @@ EvalStatsCmd( int decadeHigh, minSizeDecade, maxSizeDecade, length, i; char *litTableStats; LiteralEntry *entryPtr; + Tcl_Obj *objPtr; + +#define Percent(a,b) ((a) * 100.0 / (b)) + + objPtr = Tcl_NewObj(); + Tcl_IncrRefCount(objPtr); numInstructions = 0.0; for (i = 0; i < 256; i++) { @@ -6958,7 +10189,7 @@ EvalStatsCmd( numCurrentByteCodes = statsPtr->numCompilations - statsPtr->numByteCodesFreed; currentHeaderBytes = numCurrentByteCodes - * (sizeof(ByteCode) - (sizeof(size_t) + sizeof(Tcl_Time))); + * (sizeof(ByteCode) - sizeof(size_t) - sizeof(Tcl_Time)); literalMgmtBytes = sizeof(LiteralTable) + (iPtr->literalTable.numBuckets * sizeof(LiteralEntry *)) + (iPtr->literalTable.numEntries * sizeof(LiteralEntry)); @@ -6971,65 +10202,65 @@ EvalStatsCmd( * Summary statistics, total and current source and ByteCode sizes. */ - fprintf(stdout, "\n----------------------------------------------------------------\n"); - fprintf(stdout, - "Compilation and execution statistics for interpreter 0x%x\n", - (unsigned int) iPtr); + Tcl_AppendPrintfToObj(objPtr, "\n----------------------------------------------------------------\n"); + Tcl_AppendPrintfToObj(objPtr, + "Compilation and execution statistics for interpreter %#lx\n", + (long int)iPtr); - fprintf(stdout, "\nNumber ByteCodes executed %ld\n", + Tcl_AppendPrintfToObj(objPtr, "\nNumber ByteCodes executed\t%ld\n", statsPtr->numExecutions); - fprintf(stdout, "Number ByteCodes compiled %ld\n", + Tcl_AppendPrintfToObj(objPtr, "Number ByteCodes compiled\t%ld\n", statsPtr->numCompilations); - fprintf(stdout, " Mean executions/compile %.1f\n", - ((float)statsPtr->numExecutions) / ((float)statsPtr->numCompilations)); + Tcl_AppendPrintfToObj(objPtr, " Mean executions/compile\t%.1f\n", + statsPtr->numExecutions / (float)statsPtr->numCompilations); - fprintf(stdout, "\nInstructions executed %.0f\n", + Tcl_AppendPrintfToObj(objPtr, "\nInstructions executed\t\t%.0f\n", numInstructions); - fprintf(stdout, " Mean inst/compile %.0f\n", + Tcl_AppendPrintfToObj(objPtr, " Mean inst/compile\t\t%.0f\n", numInstructions / statsPtr->numCompilations); - fprintf(stdout, " Mean inst/execution %.0f\n", + Tcl_AppendPrintfToObj(objPtr, " Mean inst/execution\t\t%.0f\n", numInstructions / statsPtr->numExecutions); - fprintf(stdout, "\nTotal ByteCodes %ld\n", + Tcl_AppendPrintfToObj(objPtr, "\nTotal ByteCodes\t\t\t%ld\n", statsPtr->numCompilations); - fprintf(stdout, " Source bytes %.6g\n", + Tcl_AppendPrintfToObj(objPtr, " Source bytes\t\t\t%.6g\n", statsPtr->totalSrcBytes); - fprintf(stdout, " Code bytes %.6g\n", + Tcl_AppendPrintfToObj(objPtr, " Code bytes\t\t\t%.6g\n", totalCodeBytes); - fprintf(stdout, " ByteCode bytes %.6g\n", + Tcl_AppendPrintfToObj(objPtr, " ByteCode bytes\t\t%.6g\n", statsPtr->totalByteCodeBytes); - fprintf(stdout, " Literal bytes %.6g\n", + Tcl_AppendPrintfToObj(objPtr, " Literal bytes\t\t%.6g\n", totalLiteralBytes); - fprintf(stdout, " table %d + bkts %d + entries %ld + objects %ld + 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); - fprintf(stdout, " Mean code/compile %.1f\n", + Tcl_AppendPrintfToObj(objPtr, " Mean code/compile\t\t%.1f\n", totalCodeBytes / statsPtr->numCompilations); - fprintf(stdout, " Mean code/source %.1f\n", + Tcl_AppendPrintfToObj(objPtr, " Mean code/source\t\t%.1f\n", totalCodeBytes / statsPtr->totalSrcBytes); - fprintf(stdout, "\nCurrent (active) ByteCodes %ld\n", + Tcl_AppendPrintfToObj(objPtr, "\nCurrent (active) ByteCodes\t%ld\n", numCurrentByteCodes); - fprintf(stdout, " Source bytes %.6g\n", + Tcl_AppendPrintfToObj(objPtr, " Source bytes\t\t\t%.6g\n", statsPtr->currentSrcBytes); - fprintf(stdout, " Code bytes %.6g\n", + Tcl_AppendPrintfToObj(objPtr, " Code bytes\t\t\t%.6g\n", currentCodeBytes); - fprintf(stdout, " ByteCode bytes %.6g\n", + Tcl_AppendPrintfToObj(objPtr, " ByteCode bytes\t\t%.6g\n", statsPtr->currentByteCodeBytes); - fprintf(stdout, " Literal bytes %.6g\n", + Tcl_AppendPrintfToObj(objPtr, " Literal bytes\t\t%.6g\n", currentLiteralBytes); - fprintf(stdout, " table %d + bkts %d + entries %d + objects %d + 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); - fprintf(stdout, " Mean code/source %.1f\n", + Tcl_AppendPrintfToObj(objPtr, " Mean code/source\t\t%.1f\n", currentCodeBytes / statsPtr->currentSrcBytes); - fprintf(stdout, " Code + source bytes %.6g (%0.1f mean code/src)\n", + Tcl_AppendPrintfToObj(objPtr, " Code + source bytes\t\t%.6g (%0.1f mean code/src)\n", (currentCodeBytes + statsPtr->currentSrcBytes), (currentCodeBytes / statsPtr->currentSrcBytes) + 1.0); @@ -7041,18 +10272,18 @@ EvalStatsCmd( */ numSharedMultX = 0; - fprintf(stdout, "\nTcl_IsShared object check (all objects):\n"); - fprintf(stdout, " Object had refcount <=1 (not shared) %ld\n", + Tcl_AppendPrintfToObj(objPtr, "\nTcl_IsShared object check (all objects):\n"); + Tcl_AppendPrintfToObj(objPtr, " Object had refcount <=1 (not shared)\t%ld\n", tclObjsShared[1]); for (i = 2; i < TCL_MAX_SHARED_OBJ_STATS; i++) { - fprintf(stdout, " refcount ==%d %ld\n", + Tcl_AppendPrintfToObj(objPtr, " refcount ==%d\t\t%ld\n", i, tclObjsShared[i]); numSharedMultX += tclObjsShared[i]; } - fprintf(stdout, " refcount >=%d %ld\n", + Tcl_AppendPrintfToObj(objPtr, " refcount >=%d\t\t%ld\n", i, tclObjsShared[0]); numSharedMultX += tclObjsShared[0]; - fprintf(stdout, " Total shared objects %d\n", + Tcl_AppendPrintfToObj(objPtr, " Total shared objects\t\t\t%d\n", numSharedMultX); /* @@ -7062,11 +10293,11 @@ EvalStatsCmd( numByteCodeLits = 0; refCountSum = 0; numSharedMultX = 0; - numSharedOnce = 0; - objBytesIfUnshared = 0.0; - strBytesIfUnshared = 0.0; + numSharedOnce = 0; + objBytesIfUnshared = 0.0; + strBytesIfUnshared = 0.0; strBytesSharedMultX = 0.0; - strBytesSharedOnce = 0.0; + strBytesSharedOnce = 0.0; for (i = 0; i < globalTablePtr->numBuckets; i++) { for (entryPtr = globalTablePtr->buckets[i]; entryPtr != NULL; entryPtr = entryPtr->nextPtr) { @@ -7089,93 +10320,93 @@ EvalStatsCmd( sharingBytesSaved = (objBytesIfUnshared + strBytesIfUnshared) - currentLiteralBytes; - fprintf(stdout, "\nTotal objects (all interps) %ld\n", + Tcl_AppendPrintfToObj(objPtr, "\nTotal objects (all interps)\t%ld\n", tclObjsAlloced); - fprintf(stdout, "Current objects %ld\n", + Tcl_AppendPrintfToObj(objPtr, "Current objects\t\t\t%ld\n", (tclObjsAlloced - tclObjsFreed)); - fprintf(stdout, "Total literal objects %ld\n", + Tcl_AppendPrintfToObj(objPtr, "Total literal objects\t\t%ld\n", statsPtr->numLiteralsCreated); - fprintf(stdout, "\nCurrent literal objects %d (%0.1f%% of current objects)\n", + Tcl_AppendPrintfToObj(objPtr, "\nCurrent literal objects\t\t%d (%0.1f%% of current objects)\n", globalTablePtr->numEntries, - (globalTablePtr->numEntries * 100.0) / (tclObjsAlloced-tclObjsFreed)); - fprintf(stdout, " ByteCode literals %ld (%0.1f%% of current literals)\n", + Percent(globalTablePtr->numEntries, tclObjsAlloced-tclObjsFreed)); + Tcl_AppendPrintfToObj(objPtr, " ByteCode literals\t\t%ld (%0.1f%% of current literals)\n", numByteCodeLits, - (numByteCodeLits * 100.0) / globalTablePtr->numEntries); - fprintf(stdout, " Literals reused > 1x %d\n", + Percent(numByteCodeLits, globalTablePtr->numEntries)); + Tcl_AppendPrintfToObj(objPtr, " Literals reused > 1x\t\t%d\n", numSharedMultX); - fprintf(stdout, " Mean reference count %.2f\n", + Tcl_AppendPrintfToObj(objPtr, " Mean reference count\t\t%.2f\n", ((double) refCountSum) / globalTablePtr->numEntries); - fprintf(stdout, " Mean len, str reused >1x %.2f\n", - (numSharedMultX? (strBytesSharedMultX/numSharedMultX) : 0.0)); - fprintf(stdout, " Mean len, str used 1x %.2f\n", - (numSharedOnce? (strBytesSharedOnce/numSharedOnce) : 0.0)); - fprintf(stdout, " Total sharing savings %.6g (%0.1f%% of bytes if no sharing)\n", + Tcl_AppendPrintfToObj(objPtr, " Mean len, str reused >1x \t%.2f\n", + (numSharedMultX ? strBytesSharedMultX/numSharedMultX : 0.0)); + Tcl_AppendPrintfToObj(objPtr, " Mean len, str used 1x\t\t%.2f\n", + (numSharedOnce ? strBytesSharedOnce/numSharedOnce : 0.0)); + Tcl_AppendPrintfToObj(objPtr, " Total sharing savings\t\t%.6g (%0.1f%% of bytes if no sharing)\n", sharingBytesSaved, - (sharingBytesSaved * 100.0) / (objBytesIfUnshared + strBytesIfUnshared)); - fprintf(stdout, " Bytes with sharing %.6g\n", + Percent(sharingBytesSaved, objBytesIfUnshared+strBytesIfUnshared)); + Tcl_AppendPrintfToObj(objPtr, " Bytes with sharing\t\t%.6g\n", currentLiteralBytes); - fprintf(stdout, " table %d + bkts %d + entries %d + objects %d + 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); - fprintf(stdout, " Bytes if no sharing %.6g = objects %.6g + strings %.6g\n", + Tcl_AppendPrintfToObj(objPtr, " Bytes if no sharing\t\t%.6g = objects %.6g + strings %.6g\n", (objBytesIfUnshared + strBytesIfUnshared), objBytesIfUnshared, strBytesIfUnshared); - fprintf(stdout, " String sharing savings %.6g = unshared %.6g - shared %.6g\n", + Tcl_AppendPrintfToObj(objPtr, " String sharing savings \t%.6g = unshared %.6g - shared %.6g\n", (strBytesIfUnshared - statsPtr->currentLitStringBytes), strBytesIfUnshared, statsPtr->currentLitStringBytes); - fprintf(stdout, " Literal mgmt overhead %ld (%0.1f%% of bytes with sharing)\n", + Tcl_AppendPrintfToObj(objPtr, " Literal mgmt overhead\t\t%ld (%0.1f%% of bytes with sharing)\n", literalMgmtBytes, - (literalMgmtBytes * 100.0) / currentLiteralBytes); - fprintf(stdout, " table %d + buckets %d + entries %d\n", - sizeof(LiteralTable), - iPtr->literalTable.numBuckets * sizeof(LiteralEntry *), - iPtr->literalTable.numEntries * sizeof(LiteralEntry)); + Percent(literalMgmtBytes, currentLiteralBytes)); + Tcl_AppendPrintfToObj(objPtr, " table %lu + buckets %lu + entries %lu\n", + (unsigned long) sizeof(LiteralTable), + (unsigned long) (iPtr->literalTable.numBuckets * sizeof(LiteralEntry *)), + (unsigned long) (iPtr->literalTable.numEntries * sizeof(LiteralEntry))); /* * Breakdown of current ByteCode space requirements. */ - fprintf(stdout, "\nBreakdown of current ByteCode requirements:\n"); - fprintf(stdout, " Bytes Pct of Avg per\n"); - fprintf(stdout, " total ByteCode\n"); - fprintf(stdout, "Total %12.6g 100.00%% %8.1f\n", + Tcl_AppendPrintfToObj(objPtr, "\nBreakdown of current ByteCode requirements:\n"); + Tcl_AppendPrintfToObj(objPtr, " Bytes Pct of Avg per\n"); + Tcl_AppendPrintfToObj(objPtr, " total ByteCode\n"); + Tcl_AppendPrintfToObj(objPtr, "Total %12.6g 100.00%% %8.1f\n", statsPtr->currentByteCodeBytes, statsPtr->currentByteCodeBytes / numCurrentByteCodes); - fprintf(stdout, "Header %12.6g %8.1f%% %8.1f\n", + Tcl_AppendPrintfToObj(objPtr, "Header %12.6g %8.1f%% %8.1f\n", currentHeaderBytes, - ((currentHeaderBytes * 100.0) / statsPtr->currentByteCodeBytes), + Percent(currentHeaderBytes, statsPtr->currentByteCodeBytes), currentHeaderBytes / numCurrentByteCodes); - fprintf(stdout, "Instructions %12.6g %8.1f%% %8.1f\n", + Tcl_AppendPrintfToObj(objPtr, "Instructions %12.6g %8.1f%% %8.1f\n", statsPtr->currentInstBytes, - ((statsPtr->currentInstBytes * 100.0) / statsPtr->currentByteCodeBytes), + Percent(statsPtr->currentInstBytes,statsPtr->currentByteCodeBytes), statsPtr->currentInstBytes / numCurrentByteCodes); - fprintf(stdout, "Literal ptr array %12.6g %8.1f%% %8.1f\n", + Tcl_AppendPrintfToObj(objPtr, "Literal ptr array %12.6g %8.1f%% %8.1f\n", statsPtr->currentLitBytes, - ((statsPtr->currentLitBytes * 100.0) / statsPtr->currentByteCodeBytes), + Percent(statsPtr->currentLitBytes,statsPtr->currentByteCodeBytes), statsPtr->currentLitBytes / numCurrentByteCodes); - fprintf(stdout, "Exception table %12.6g %8.1f%% %8.1f\n", + Tcl_AppendPrintfToObj(objPtr, "Exception table %12.6g %8.1f%% %8.1f\n", statsPtr->currentExceptBytes, - ((statsPtr->currentExceptBytes * 100.0) / statsPtr->currentByteCodeBytes), + Percent(statsPtr->currentExceptBytes,statsPtr->currentByteCodeBytes), statsPtr->currentExceptBytes / numCurrentByteCodes); - fprintf(stdout, "Auxiliary data %12.6g %8.1f%% %8.1f\n", + Tcl_AppendPrintfToObj(objPtr, "Auxiliary data %12.6g %8.1f%% %8.1f\n", statsPtr->currentAuxBytes, - ((statsPtr->currentAuxBytes * 100.0) / statsPtr->currentByteCodeBytes), + Percent(statsPtr->currentAuxBytes,statsPtr->currentByteCodeBytes), statsPtr->currentAuxBytes / numCurrentByteCodes); - fprintf(stdout, "Command map %12.6g %8.1f%% %8.1f\n", + Tcl_AppendPrintfToObj(objPtr, "Command map %12.6g %8.1f%% %8.1f\n", statsPtr->currentCmdMapBytes, - ((statsPtr->currentCmdMapBytes * 100.0) / statsPtr->currentByteCodeBytes), + Percent(statsPtr->currentCmdMapBytes,statsPtr->currentByteCodeBytes), statsPtr->currentCmdMapBytes / numCurrentByteCodes); /* * Detailed literal statistics. */ - fprintf(stdout, "\nLiteral string sizes:\n"); - fprintf(stdout, " Up to length Percentage\n"); + Tcl_AppendPrintfToObj(objPtr, "\nLiteral string sizes:\n"); + Tcl_AppendPrintfToObj(objPtr, "\t Up to length\t\tPercentage\n"); maxSizeDecade = 0; for (i = 31; i >= 0; i--) { if (statsPtr->literalCount[i] > 0) { @@ -7187,21 +10418,21 @@ EvalStatsCmd( for (i = 0; i <= maxSizeDecade; i++) { decadeHigh = (1 << (i+1)) - 1; sum += statsPtr->literalCount[i]; - fprintf(stdout, " %10d %8.0f%%\n", - decadeHigh, (sum * 100.0) / statsPtr->numLiteralsCreated); + Tcl_AppendPrintfToObj(objPtr, "\t%10d\t\t%8.0f%%\n", + decadeHigh, Percent(sum, statsPtr->numLiteralsCreated)); } litTableStats = TclLiteralStats(globalTablePtr); - fprintf(stdout, "\nCurrent literal table statistics:\n%s\n", + Tcl_AppendPrintfToObj(objPtr, "\nCurrent literal table statistics:\n%s\n", litTableStats); - ckfree((char *) litTableStats); + ckfree(litTableStats); /* * Source and ByteCode size distributions. */ - fprintf(stdout, "\nSource sizes:\n"); - fprintf(stdout, " Up to size Percentage\n"); + Tcl_AppendPrintfToObj(objPtr, "\nSource sizes:\n"); + Tcl_AppendPrintfToObj(objPtr, "\t Up to size\t\tPercentage\n"); minSizeDecade = maxSizeDecade = 0; for (i = 0; i < 31; i++) { if (statsPtr->srcCount[i] > 0) { @@ -7219,12 +10450,12 @@ EvalStatsCmd( for (i = minSizeDecade; i <= maxSizeDecade; i++) { decadeHigh = (1 << (i+1)) - 1; sum += statsPtr->srcCount[i]; - fprintf(stdout, " %10d %8.0f%%\n", - decadeHigh, (sum * 100.0) / statsPtr->numCompilations); + Tcl_AppendPrintfToObj(objPtr, "\t%10d\t\t%8.0f%%\n", + decadeHigh, Percent(sum, statsPtr->numCompilations)); } - fprintf(stdout, "\nByteCode sizes:\n"); - fprintf(stdout, " Up to size Percentage\n"); + Tcl_AppendPrintfToObj(objPtr, "\nByteCode sizes:\n"); + Tcl_AppendPrintfToObj(objPtr, "\t Up to size\t\tPercentage\n"); minSizeDecade = maxSizeDecade = 0; for (i = 0; i < 31; i++) { if (statsPtr->byteCodeCount[i] > 0) { @@ -7242,12 +10473,12 @@ EvalStatsCmd( for (i = minSizeDecade; i <= maxSizeDecade; i++) { decadeHigh = (1 << (i+1)) - 1; sum += statsPtr->byteCodeCount[i]; - fprintf(stdout, " %10d %8.0f%%\n", - decadeHigh, (sum * 100.0) / statsPtr->numCompilations); + Tcl_AppendPrintfToObj(objPtr, "\t%10d\t\t%8.0f%%\n", + decadeHigh, Percent(sum, statsPtr->numCompilations)); } - fprintf(stdout, "\nByteCode longevity (excludes Current ByteCodes):\n"); - fprintf(stdout, " Up to ms Percentage\n"); + Tcl_AppendPrintfToObj(objPtr, "\nByteCode longevity (excludes Current ByteCodes):\n"); + Tcl_AppendPrintfToObj(objPtr, "\t Up to ms\t\tPercentage\n"); minSizeDecade = maxSizeDecade = 0; for (i = 0; i < 31; i++) { if (statsPtr->lifetimeCount[i] > 0) { @@ -7265,37 +10496,54 @@ EvalStatsCmd( for (i = minSizeDecade; i <= maxSizeDecade; i++) { decadeHigh = (1 << (i+1)) - 1; sum += statsPtr->lifetimeCount[i]; - fprintf(stdout, " %12.3f %8.0f%%\n", - decadeHigh / 1000.0, - (sum * 100.0) / statsPtr->numByteCodesFreed); + Tcl_AppendPrintfToObj(objPtr, "\t%12.3f\t\t%8.0f%%\n", + decadeHigh/1000.0, Percent(sum, statsPtr->numByteCodesFreed)); } /* * Instruction counts. */ - fprintf(stdout, "\nInstruction counts:\n"); + Tcl_AppendPrintfToObj(objPtr, "\nInstruction counts:\n"); for (i = 0; i <= LAST_INST_OPCODE; i++) { + Tcl_AppendPrintfToObj(objPtr, "%20s %8ld ", + tclInstructionTable[i].name, statsPtr->instructionCount[i]); if (statsPtr->instructionCount[i]) { - fprintf(stdout, "%20s %8ld %6.1f%%\n", - tclInstructionTable[i].name, - statsPtr->instructionCount[i], - (statsPtr->instructionCount[i]*100.0) / numInstructions); - } - } - - fprintf(stdout, "\nInstructions NEVER executed:\n"); - for (i = 0; i <= LAST_INST_OPCODE; i++) { - if (statsPtr->instructionCount[i] == 0) { - fprintf(stdout, "%20s\n", tclInstructionTable[i].name); + Tcl_AppendPrintfToObj(objPtr, "%6.1f%%\n", + Percent(statsPtr->instructionCount[i], numInstructions)); + } else { + Tcl_AppendPrintfToObj(objPtr, "0\n"); } } #ifdef TCL_MEM_DEBUG - fprintf(stdout, "\nHeap Statistics:\n"); - TclDumpMemoryInfo(stdout); + Tcl_AppendPrintfToObj(objPtr, "\nHeap Statistics:\n"); + TclDumpMemoryInfo((ClientData) objPtr, 1); #endif - fprintf(stdout, "\n----------------------------------------------------------------\n"); + Tcl_AppendPrintfToObj(objPtr, "\n----------------------------------------------------------------\n"); + + if (objc == 1) { + Tcl_SetObjResult(interp, objPtr); + } else { + Tcl_Channel outChan; + char *str = Tcl_GetStringFromObj(objv[1], &length); + + if (length) { + if (strcmp(str, "stdout") == 0) { + outChan = Tcl_GetStdChannel(TCL_STDOUT); + } else if (strcmp(str, "stderr") == 0) { + outChan = Tcl_GetStdChannel(TCL_STDERR); + } else { + outChan = Tcl_OpenFileChannel(NULL, str, "w", 0664); + } + } else { + outChan = Tcl_GetStdChannel(TCL_STDOUT); + } + if (outChan != NULL) { + Tcl_WriteObj(outChan, objPtr); + } + } + Tcl_DecrRefCount(objPtr); return TCL_OK; } #endif /* TCL_COMPILE_STATS */ @@ -7311,10 +10559,10 @@ EvalStatsCmd( * * Results: * If the result code is one of the standard Tcl return codes, the result - * is a string representing that code such as "TCL_ERROR". Otherwise, - * the result string is that code formatted as a sequence of decimal - * digit characters. Note that the resulting string must not be modified - * by the caller. + * is a string representing that code such as "TCL_ERROR". Otherwise, the + * result string is that code formatted as a sequence of decimal digit + * characters. Note that the resulting string must not be modified by the + * caller. * * Side effects: * None. @@ -7322,7 +10570,7 @@ EvalStatsCmd( *---------------------------------------------------------------------- */ -static char * +static const char * StringForResultCode( int result) /* The Tcl result code for which to generate a * string. */ @@ -7336,143 +10584,6 @@ StringForResultCode( return buf; } #endif /* TCL_COMPILE_DEBUG */ -#if 0 - -/* - *---------------------------------------------------------------------- - * - * ExponWide -- - * - * Procedure to return w**w2 as wide integer - * - * Results: - * Return value is w to the power w2, unless the computation makes no - * sense mathematically. In that case *errExpon is set to 1. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static Tcl_WideInt -ExponWide( - Tcl_WideInt w, /* The value that must be exponentiated */ - Tcl_WideInt w2, /* The exponent */ - int *errExpon) /* Error code */ -{ - Tcl_WideInt result; - - *errExpon = 0; - - /* - * Check for possible errors and simple/edge cases - */ - - if (w == 0) { - if (w2 < 0) { - *errExpon = 1; - return W0; - } else if (w2 > 0) { - return W0; - } - return Tcl_LongAsWide(1); /* By definition and analysis */ - } else if (w < -1) { - if (w2 < 0) { - return W0; - } else if (w2 == 0) { - return Tcl_LongAsWide(1); - } - } else if (w == -1) { - return (w2 & 1) ? Tcl_LongAsWide(-1) : Tcl_LongAsWide(1); - } else if ((w == 1) || (w2 == 0)) { - return Tcl_LongAsWide(1); - } else if (w>1 && w2<0) { - return W0; - } - - /* - * The general case. - */ - - result = Tcl_LongAsWide(1); - for (; w2>Tcl_LongAsWide(1) ; w*=w,w2/=2) { - if (w2 & 1) { - result *= w; - } - } - return result * w; -} - -/* - *---------------------------------------------------------------------- - * - * ExponLong -- - * - * Procedure to return i**i2 as long integer - * - * Results: - * Return value is i to the power i2, unless the computation makes no - * sense mathematically. In that case *errExpon is set to 1. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static long -ExponLong( - long i, /* The value that must be exponentiated */ - long i2, /* The exponent */ - int *errExpon) /* Error code */ -{ - long result; - - *errExpon = 0; - - /* - * Check for possible errors and simple cases - */ - - if (i == 0) { - if (i2 < 0) { - *errExpon = 1; - return 0L; - } else if (i2 > 0) { - return 0L; - } - /* - * By definition and analysis, 0**0 is 1. - */ - return 1L; - } else if (i < -1) { - if (i2 < 0) { - return 0L; - } else if (i2 == 0) { - return 1L; - } - } else if (i == -1) { - return (i2&1) ? -1L : 1L; - } else if ((i == 1) || (i2 == 0)) { - return 1L; - } else if (i > 1 && i2 < 0) { - return 0L; - } - - /* - * The general case - */ - - result = 1; - for (; i2>1 ; i*=i,i2/=2) { - if (i2 & 1) { - result *= i; - } - } - return result * i; -} -#endif /* * Local Variables: |