summaryrefslogtreecommitdiffstats
path: root/generic/tclExecute.c
diff options
context:
space:
mode:
Diffstat (limited to 'generic/tclExecute.c')
-rw-r--r--generic/tclExecute.c8280
1 files changed, 4660 insertions, 3620 deletions
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index e657828..0ca393b 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -6,9 +6,10 @@
* 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) 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.
@@ -16,10 +17,13 @@
#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
@@ -50,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,
@@ -73,7 +79,7 @@ int tclTraceExec = 0;
* disjoint for backward-compatability reasons.
*/
-static const char *operatorStrings[] = {
+static const char *const operatorStrings[] = {
"||", "&&", "|", "^", "&", "==", "!=", "<", ">", "<=", ">=", "<<", ">>",
"+", "-", "*", "/", "%", "+", "-", "~", "!",
"BUILTIN FUNCTION", "FUNCTION",
@@ -86,7 +92,7 @@ static const char *operatorStrings[] = {
*/
#ifdef TCL_COMPILE_DEBUG
-static const char *resultStrings[] = {
+static const char *const resultStrings[] = {
"TCL_OK", "TCL_ERROR", "TCL_RETURN", "TCL_BREAK", "TCL_CONTINUE"
};
#endif
@@ -117,7 +123,7 @@ long tclObjsShared[TCL_MAX_SHARED_OBJ_STATS] = { 0, 0, 0, 0, 0 };
typedef struct {
const char *name; /* Name of function. */
- int numArgs; /* Number of arguments for function. */
+ int numArgs; /* Number of arguments for function. */
} BuiltinFunc;
/*
@@ -126,7 +132,7 @@ typedef struct {
* operand byte.
*/
-static const BuiltinFunc tclBuiltinFuncTable[] = {
+static BuiltinFunc const tclBuiltinFuncTable[] = {
{"acos", 1},
{"asin", 1},
{"atan", 1},
@@ -158,7 +164,58 @@ static const BuiltinFunc tclBuiltinFuncTable[] = {
#define LAST_BUILTIN_FUNC 25
#endif
+
+/*
+ * NR_TEBC
+ * Helpers for NR - non-recursive calls to TEBC
+ * Minimal data required to fully reconstruct the execution state.
+ */
+typedef struct TEBCdata {
+ ByteCode *codePtr; /* Constant until the BC returns */
+ /* -----------------------------------------*/
+ const unsigned char *pc; /* These fields are used on return TO this */
+ ptrdiff_t *catchTop; /* this level: they record the state when a */
+ int cleanup; /* new codePtr was received for NR */
+ Tcl_Obj *auxObjList; /* execution. */
+ int checkInterp;
+ CmdFrame cmdFrame;
+ void *stack[1]; /* Start of the actual combined catch and obj
+ * stacks; the struct will be expanded as
+ * necessary */
+} TEBCdata;
+
+#define TEBC_YIELD() \
+ do { \
+ esPtr->tosPtr = tosPtr; \
+ TD->pc = pc; \
+ TD->cleanup = cleanup; \
+ TclNRAddCallback(interp, TEBCresume, TD, INT2PTR(1), NULL, NULL); \
+ } while (0)
+
+#define TEBC_DATA_DIG() \
+ do { \
+ pc = TD->pc; \
+ cleanup = TD->cleanup; \
+ tosPtr = esPtr->tosPtr; \
+ } while (0)
+
+#define PUSH_TAUX_OBJ(objPtr) \
+ do { \
+ 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
*/
@@ -172,8 +229,8 @@ VarHashCreateVar(
Tcl_Obj *key,
int *newPtr)
{
- Tcl_HashEntry *hPtr = Tcl_CreateHashEntry((Tcl_HashTable *) tablePtr,
- (char *) key, newPtr);
+ Tcl_HashEntry *hPtr = Tcl_CreateHashEntry(&tablePtr->table,
+ key, newPtr);
if (!hPtr) {
return NULL;
@@ -183,7 +240,7 @@ VarHashCreateVar(
#define VarHashFindVar(tablePtr, key) \
VarHashCreateVar((tablePtr), (key), NULL)
-
+
/*
* The new macro for ending an instruction; note that a reasonable C-optimiser
* will resolve all branches at compile time. (result) is always a constant;
@@ -196,56 +253,77 @@ VarHashCreateVar(
* resultHandling: 0 indicates no object should be pushed on the stack;
* otherwise, push objResultPtr. If (result < 0), objResultPtr already
* has the correct reference count.
+ *
+ * We use the new compile-time assertions to check that nCleanup is constant
+ * and within range.
*/
-#define NEXT_INST_F(pcAdjustment, nCleanup, resultHandling) \
- if (nCleanup == 0) {\
- if (resultHandling != 0) {\
- if ((resultHandling) > 0) {\
- PUSH_OBJECT(objResultPtr);\
- } else {\
- *(++tosPtr) = objResultPtr;\
- }\
- } \
- pc += (pcAdjustment);\
- goto cleanup0;\
- } else if (resultHandling != 0) {\
- if ((resultHandling) > 0) {\
- Tcl_IncrRefCount(objResultPtr);\
- }\
- pc += (pcAdjustment);\
- switch (nCleanup) {\
- case 1: goto cleanup1_pushObjResultPtr;\
- case 2: goto cleanup2_pushObjResultPtr;\
- default: Tcl_Panic("bad usage of macro NEXT_INST_F");\
- }\
- } else {\
- pc += (pcAdjustment);\
- switch (nCleanup) {\
- case 1: goto cleanup1;\
- case 2: goto cleanup2;\
- default: Tcl_Panic("bad usage of macro NEXT_INST_F");\
- }\
- }
-
-#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; \
+ } \
+ } else { \
+ pc += (pcAdjustment); \
+ switch (nCleanup) { \
+ case 1: goto cleanup1; \
+ case 2: goto cleanup2; \
+ } \
+ } \
+ } 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)
/*
* 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() \
@@ -280,36 +358,39 @@ VarHashCreateVar(
#define OBJ_AT_DEPTH(n) *(tosPtr-(n))
-#define CURR_DEPTH (tosPtr - initTosPtr)
+#define CURR_DEPTH ((ptrdiff_t) (tosPtr - initTosPtr))
/*
* 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, \
- (int) CURR_DEPTH, \
- (unsigned)(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_WITH_OBJ(a, objPtr) \
- if (traceInstructions) { \
- fprintf(stdout, "%2d: %2d (%u) %s ", iPtr->numLevels, \
- (int) CURR_DEPTH, \
- (unsigned)(pc - codePtr->codeStart), \
- GetOpcodeName(pc)); \
- printf a; \
- TclPrintObject(stdout, objPtr, 30); \
- fprintf(stdout, "\n"); \
+ 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) : "")
@@ -325,23 +406,29 @@ VarHashCreateVar(
*/
#define TCL_DTRACE_INST_NEXT() \
- 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);\
- }
+ 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() \
- if (TCL_DTRACE_INST_DONE_ENABLED() && curInstName) {\
- TCL_DTRACE_INST_DONE(curInstName, (int) CURR_DEPTH, tosPtr);\
- }
-
+ 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:
@@ -350,9 +437,8 @@ VarHashCreateVar(
* 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) \
@@ -367,10 +453,8 @@ VarHashCreateVar(
(((objPtr)->bytes != NULL) && ((objPtr)->length == 0))) \
? 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) \
@@ -389,8 +473,7 @@ VarHashCreateVar(
(((objPtr)->bytes != NULL) && ((objPtr)->length == 0))) \
? 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
@@ -400,7 +483,7 @@ VarHashCreateVar(
* int *boolPtr);
*/
-#define TclGetBooleanFromObj(interp, objPtr, boolPtr) \
+#define TclGetBooleanFromObj(interp, objPtr, boolPtr) \
((((objPtr)->typePtr == &tclIntType) \
|| ((objPtr)->typePtr == &tclBooleanType)) \
? (*(boolPtr) = ((objPtr)->internalRep.longValue!=0), TCL_OK) \
@@ -414,13 +497,13 @@ VarHashCreateVar(
* 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) : \
@@ -428,7 +511,7 @@ VarHashCreateVar(
? (*(wideIntPtr) = (Tcl_WideInt) \
((objPtr)->internalRep.longValue), TCL_OK) : \
Tcl_GetWideIntFromObj((interp), (objPtr), (wideIntPtr)))
-#endif
+#endif /* TCL_WIDE_INT_IS_LONG */
/*
* Macro used to make the check for type overflow more mnemonic. This works by
@@ -444,24 +527,25 @@ VarHashCreateVar(
#define Overflowing(a,b,sum) ((((a)^(sum)) < 0) && (((a)^(b)) >= 0))
/*
- * Custom object type only used in this file; values of its type should never
- * be seen by user scripts.
+ * Macro for checking whether the type is NaN, used when we're thinking about
+ * throwing an error for supplying a non-number number.
*/
-static Tcl_ObjType dictIteratorType = {
- "dictIterator",
- NULL, NULL, NULL, NULL
-};
-
+#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
+ * Auxiliary tables used to compute powers of small integers.
*/
#if (LONG_MAX == 0x7fffffff)
/*
* Maximum base that, when raised to powers 2, 3, ... 8, fits in a 32-bit
- * signed integer
+ * signed integer.
*/
static const long MaxBase32[] = {46340, 1290, 215, 73, 35, 21, 14};
@@ -476,7 +560,8 @@ static const size_t MaxBase32Size = sizeof(MaxBase32)/sizeof(long);
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 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,
@@ -486,7 +571,6 @@ static const long Exp32Value[] = {
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)
@@ -506,14 +590,15 @@ static const Tcl_WideInt MaxBase64[] = {
static const size_t MaxBase64Size = sizeof(MaxBase64)/sizeof(Tcl_WideInt);
/*
- *Table giving 3, 4, ..., 13 raised to powers greater than 16 when the
+ * Table giving 3, 4, ..., 13 raised to powers greater than 16 when the
* results fit in a 64-bit signed integer.
*/
static const unsigned short Exp64Index[] = {
0, 23, 38, 49, 57, 63, 67, 70, 72, 74, 75, 76
};
-static const size_t Exp64IndexSize = sizeof(Exp64Index)/sizeof(unsigned short);
+static const size_t Exp64IndexSize =
+ sizeof(Exp64Index) / sizeof(unsigned short);
static const Tcl_WideInt Exp64Value[] = {
(Tcl_WideInt)243*243*243*3*3,
(Tcl_WideInt)243*243*243*3*3*3,
@@ -592,10 +677,17 @@ static const Tcl_WideInt Exp64Value[] = {
(Tcl_WideInt)248832*248832*248832*12*12,
(Tcl_WideInt)371293*371293*371293*13*13
};
-static const size_t Exp64ValueSize = sizeof(Exp64Value)/sizeof(Tcl_WideInt);
+static const size_t Exp64ValueSize = sizeof(Exp64Value) / sizeof(Tcl_WideInt);
+#endif /* (LONG_MAX > 0x7fffffff) || !defined(TCL_WIDE_INT_IS_LONG) */
-#endif
+/*
+ * 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:
*/
@@ -606,42 +698,107 @@ static int EvalStatsCmd(ClientData clientData,
Tcl_Obj *const objv[]);
#endif /* TCL_COMPILE_STATS */
#ifdef TCL_COMPILE_DEBUG
-static char * GetOpcodeName(unsigned char *pc);
+static const char * GetOpcodeName(const unsigned char *pc);
static void PrintByteCodeInfo(ByteCode *codePtr);
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 */
+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(unsigned char *pc, int catchOnly,
- ByteCode *codePtr);
-static const char * GetSrcInfoForPc(unsigned char *pc, ByteCode *codePtr,
- int *lengthPtr);
+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,
- unsigned char *pc, Tcl_Obj *opndPtr);
+ 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 TEBCresume;
/*
* The structure below defines a bytecode Tcl object type to hold the
* compiled bytecode for Tcl expressions.
*/
-static Tcl_ObjType exprCodeType = {
+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;
+}
/*
*----------------------------------------------------------------------
@@ -689,7 +846,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:
@@ -698,32 +855,36 @@ 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));
- ExecStack *esPtr = (ExecStack *) ckalloc(sizeof(ExecStack)
- + (size_t) (TCL_STACK_INITIAL_SIZE-1) * sizeof(Tcl_Obj *));
+ ExecEnv *eePtr = ckalloc(sizeof(ExecEnv));
+ ExecStack *esPtr = ckalloc(sizeof(ExecStack)
+ + (size_t) (size-1) * sizeof(Tcl_Obj *));
eePtr->execStackPtr = esPtr;
TclNewBooleanObj(eePtr->constants[0], 0);
Tcl_IncrRefCount(eePtr->constants[0]);
TclNewBooleanObj(eePtr->constants[1], 1);
Tcl_IncrRefCount(eePtr->constants[1]);
+ eePtr->interp = interp;
+ eePtr->callbackPtr = NULL;
+ eePtr->corPtr = NULL;
+ eePtr->rewind = 0;
esPtr->prevPtr = NULL;
esPtr->nextPtr = NULL;
esPtr->markerPtr = NULL;
- esPtr->endPtr = &esPtr->stackWords[TCL_STACK_INITIAL_SIZE-1];
+ esPtr->endPtr = &esPtr->stackWords[size-1];
esPtr->tosPtr = &esPtr->stackWords[-1];
Tcl_MutexLock(&execMutex);
@@ -736,7 +897,6 @@ TclCreateExecEnv(
return eePtr;
}
-#undef TCL_STACK_INITIAL_SIZE
/*
*----------------------------------------------------------------------
@@ -759,7 +919,7 @@ static void
DeleteExecStack(
ExecStack *esPtr)
{
- if (esPtr->markerPtr) {
+ if (esPtr->markerPtr && !cachedInExit) {
Tcl_Panic("freeing an execStack which is still in use");
}
@@ -769,7 +929,7 @@ DeleteExecStack(
if (esPtr->nextPtr) {
esPtr->nextPtr->prevPtr = esPtr->prevPtr;
}
- ckfree((char *) esPtr);
+ ckfree(esPtr);
}
void
@@ -778,6 +938,8 @@ TclDeleteExecEnv(
{
ExecStack *esPtr = eePtr->execStackPtr, *tmpPtr;
+ cachedInExit = TclInExit();
+
/*
* Delete all stacks in this exec env.
*/
@@ -793,7 +955,13 @@ TclDeleteExecEnv(
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);
}
/*
@@ -824,12 +992,12 @@ TclFinalizeExecution(void)
}
/*
- * Auxiliary code to insure that GrowEvaluationStack always returns correctly
+ * 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 *)'.
+ * multiple of the wordsize 'sizeof(Tcl_Obj *)'.
*/
#define WALLOCALIGN \
@@ -851,13 +1019,12 @@ wordSkip(
}
/*
- * Given a marker, compute where the following aligned memory starts.
+ * Given a marker, compute where the following aligned memory starts.
*/
-#define MEMSTART(markerPtr) \
+#define MEMSTART(markerPtr) \
((markerPtr) + wordSkip(markerPtr))
-
/*
*----------------------------------------------------------------------
*
@@ -899,22 +1066,24 @@ GrowEvaluationStack(
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
+ * 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;
+ memStart = tmpMarkerPtr + offset;
esPtr->tosPtr = memStart - 1;
*esPtr->markerPtr = (Tcl_Obj *) markerPtr;
return memStart;
}
+#endif
}
/*
@@ -928,6 +1097,7 @@ GrowEvaluationStack(
}
needed = growth + moveWords + WALLOCALIGN;
+
/*
* Check if there is enough room in the next stack (if there is one, it
* should be both empty and the last one!)
@@ -957,14 +1127,19 @@ GrowEvaluationStack(
* including the elements to be copied over and the new marker.
*/
+#ifndef PURIFY
newElems = 2*currElems;
while (needed > newElems) {
newElems *= 2;
}
- newBytes = sizeof (ExecStack) + (newElems-1) * sizeof(Tcl_Obj *);
+#else
+ newElems = needed;
+#endif
+
+ newBytes = sizeof(ExecStack) + (newElems-1) * sizeof(Tcl_Obj *);
oldPtr = esPtr;
- esPtr = (ExecStack *) ckalloc(newBytes);
+ esPtr = ckalloc(newBytes);
oldPtr->nextPtr = esPtr;
esPtr->prevPtr = oldPtr;
@@ -984,7 +1159,7 @@ GrowEvaluationStack(
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;
@@ -1060,7 +1235,7 @@ TclStackFree(
Interp *iPtr = (Interp *) interp;
ExecEnv *eePtr;
ExecStack *esPtr;
- Tcl_Obj **markerPtr;
+ Tcl_Obj **markerPtr, *marker;
if (iPtr == NULL || iPtr->execEnvPtr == NULL) {
ckfree((char *) freePtr);
@@ -1076,30 +1251,45 @@ TclStackFree(
eePtr = iPtr->execEnvPtr;
esPtr = eePtr->execStackPtr;
markerPtr = esPtr->markerPtr;
+ marker = *markerPtr;
- if (MEMSTART(markerPtr) != (Tcl_Obj **)freePtr) {
- Tcl_Panic("TclStackFree: incorrect freePtr. Call out of sequence?");
+ 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 **) *markerPtr;
- if (*markerPtr) {
- return;
+ esPtr->tosPtr = markerPtr - 1;
+ esPtr->markerPtr = (Tcl_Obj **) marker;
+ if (marker) {
+ return;
}
/*
- * Return to previous stack.
+ * Return to previous active stack. Note that repeated expansions or
+ * reallocs could have generated several unused intervening stacks: free
+ * them too.
*/
+ while (esPtr->nextPtr) {
+ esPtr = esPtr->nextPtr;
+ }
esPtr->tosPtr = &esPtr->stackWords[-1];
- if (esPtr->prevPtr) {
- eePtr->execStackPtr = esPtr->prevPtr;
+ while (esPtr->prevPtr) {
+ ExecStack *tmpPtr = esPtr->prevPtr;
+ if (tmpPtr->tosPtr == &tmpPtr->stackWords[-1]) {
+ DeleteExecStack(tmpPtr);
+ } else {
+ break;
+ }
}
- if (esPtr->nextPtr) {
- if (!esPtr->prevPtr) {
- eePtr->execStackPtr = esPtr->nextPtr;
- }
- DeleteExecStack(esPtr);
+ if (esPtr->prevPtr) {
+ eePtr->execStackPtr = esPtr->prevPtr;
+#ifdef PURIFY
+ eePtr->execStackPtr->nextPtr = NULL;
+ DeleteExecStack(esPtr);
+#endif
+ } else {
+ eePtr->execStackPtr = esPtr;
}
}
@@ -1178,20 +1368,123 @@ 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. */
register ByteCode *codePtr = NULL;
- /* Tcl Internal type of bytecode. Initialized
+ /* Tcl Internal type of bytecode. Initialized
* to avoid compiler warning. */
- int result;
-
- /*
- * Execute the expression after first saving the interpreter's result.
- */
-
- Tcl_Obj *saveObjPtr = Tcl_GetObjResult(interp);
- Tcl_IncrRefCount(saveObjPtr);
/*
* Get the expression ByteCode from the object. If it exists, make sure it
@@ -1200,13 +1493,13 @@ Tcl_ExprObj(
if (objPtr->typePtr == &exprCodeType) {
Namespace *namespacePtr = iPtr->varFramePtr->nsPtr;
- codePtr = (ByteCode *) objPtr->internalRep.twoPtrValue.ptr1;
+ codePtr = objPtr->internalRep.twoPtrValue.ptr1;
if (((Interp *) *codePtr->interpHandle != iPtr)
|| (codePtr->compileEpoch != iPtr->compileEpoch)
|| (codePtr->nsPtr != namespacePtr)
- || (codePtr->nsEpoch != namespacePtr->resolverEpoch)) {
- objPtr->typePtr->freeIntRepProc(objPtr);
- objPtr->typePtr = (Tcl_ObjType *) NULL;
+ || (codePtr->nsEpoch != namespacePtr->resolverEpoch)
+ || (codePtr->localCachePtr != iPtr->varFramePtr->localCachePtr)) {
+ FreeExprCodeInternalRep(objPtr);
}
}
if (objPtr->typePtr != &exprCodeType) {
@@ -1240,7 +1533,11 @@ Tcl_ExprObj(
TclInitByteCodeObj(objPtr, &compEnv);
objPtr->typePtr = &exprCodeType;
TclFreeCompileEnv(&compEnv);
- codePtr = (ByteCode *) objPtr->internalRep.twoPtrValue.ptr1;
+ 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);
@@ -1248,38 +1545,7 @@ Tcl_ExprObj(
}
#endif /* TCL_COMPILE_DEBUG */
}
-
- Tcl_ResetResult(interp);
-
- /*
- * Increment the code's ref count while it is being executed. If
- * afterwards no references to it remain, free the code.
- */
-
- codePtr->refCount++;
- result = TclExecuteByteCode(interp, codePtr);
- codePtr->refCount--;
- if (codePtr->refCount <= 0) {
- TclCleanupByteCode(codePtr);
- }
-
- /*
- * If the expression evaluated successfully, store a pointer to its value
- * object in resultPtrPtr then restore the old interpreter result. We
- * increment the object's ref count to reflect the reference that we are
- * returning to the caller. We also decrement the ref count of the
- * interpreter's result object after calling Tcl_SetResult since we next
- * store into that field directly.
- */
-
- if (result == TCL_OK) {
- *resultPtrPtr = iPtr->objResultPtr;
- Tcl_IncrRefCount(iPtr->objResultPtr);
-
- Tcl_SetObjResult(interp, saveObjPtr);
- }
- TclDecrRefCount(saveObjPtr);
- return result;
+ return codePtr;
}
/*
@@ -1288,17 +1554,17 @@ Tcl_ExprObj(
* DupExprCodeInternalRep --
*
* Part of the Tcl object type implementation for Tcl expression
- * bytecode. We do not copy the bytecode intrep. Instead, we
- * return without setting copyPtr->typePtr, so the copy is a plain
- * string copy of the expression value, and if it is to be used
- * as a compiled expression, it will just need a recompile.
- *
- * This makes sense, because with Tcl's copy-on-write practices,
- * the usual (only?) time Tcl_DuplicateObj() will be called is
- * when the copy is about to be modified, which would invalidate
- * any copied bytecode anyway. The only reason it might make sense
- * to copy the bytecode is if we had some modifying routines that
- * operated directly on the intrep, like we do for lists and dicts.
+ * bytecode. We do not copy the bytecode intrep. Instead, we return
+ * without setting copyPtr->typePtr, so the copy is a plain string copy
+ * of the expression value, and if it is to be used as a compiled
+ * expression, it will just need a recompile.
+ *
+ * This makes sense, because with Tcl's copy-on-write practices, the
+ * usual (only?) time Tcl_DuplicateObj() will be called is when the copy
+ * is about to be modified, which would invalidate any copied bytecode
+ * anyway. The only reason it might make sense to copy the bytecode is if
+ * we had some modifying routines that operated directly on the intrep,
+ * like we do for lists and dicts.
*
* Results:
* None.
@@ -1323,14 +1589,15 @@ DupExprCodeInternalRep(
* FreeExprCodeInternalRep --
*
* Part of the Tcl object type implementation for Tcl expression
- * bytecode. Frees the storage allocated to hold the internal rep,
- * unless ref counts indicate bytecode execution is still in progress.
+ * bytecode. Frees the storage allocated to hold the internal rep, unless
+ * ref counts indicate bytecode execution is still in progress.
*
* Results:
* None.
*
* Side effects:
- * May free allocated memory. Leaves objPtr untyped.
+ * May free allocated memory. Leaves objPtr untyped.
+ *
*----------------------------------------------------------------------
*/
@@ -1338,36 +1605,33 @@ static void
FreeExprCodeInternalRep(
Tcl_Obj *objPtr)
{
- ByteCode *codePtr = (ByteCode *) objPtr->internalRep.twoPtrValue.ptr1;
+ ByteCode *codePtr = objPtr->internalRep.twoPtrValue.ptr1;
+ objPtr->typePtr = NULL;
codePtr->refCount--;
if (codePtr->refCount <= 0) {
TclCleanupByteCode(codePtr);
}
- objPtr->typePtr = NULL;
}
/*
*----------------------------------------------------------------------
*
- * 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,
const CmdFrame *invoker,
@@ -1375,23 +1639,7 @@ TclCompEvalObj(
{
register Interp *iPtr = (Interp *) interp;
register ByteCode *codePtr; /* Tcl Internal type of bytecode. */
- int result;
- Namespace *namespacePtr;
-
- /*
- * Check that the interpreter is ready to execute scripts. Note that we
- * manage the interp's runlevel here: it is a small white lie (maybe), but
- * saves a ++/-- pair at each invocation. Amazingly enough, the impact on
- * performance is noticeable.
- */
-
- iPtr->numLevels++;
- if (TclInterpReady(interp) == TCL_ERROR) {
- result = TCL_ERROR;
- goto done;
- }
-
- namespacePtr = iPtr->varFramePtr->nsPtr;
+ Namespace *namespacePtr = iPtr->varFramePtr->nsPtr;
/*
* If the object is not already of tclByteCodeType, compile it (and reset
@@ -1417,40 +1665,39 @@ TclCompEvalObj(
* here.
*/
- codePtr = (ByteCode *) objPtr->internalRep.twoPtrValue.ptr1;
+ codePtr = objPtr->internalRep.twoPtrValue.ptr1;
if (((Interp *) *codePtr->interpHandle != iPtr)
|| (codePtr->compileEpoch != iPtr->compileEpoch)
|| (codePtr->nsPtr != namespacePtr)
|| (codePtr->nsEpoch != namespacePtr->resolverEpoch)) {
- if (codePtr->flags & TCL_BYTECODE_PRECOMPILED) {
- if ((Interp *) *codePtr->interpHandle != iPtr) {
- Tcl_Panic("Tcl_EvalObj: compiled script jumped interps");
- }
- codePtr->compileEpoch = iPtr->compileEpoch;
- } else {
- /*
- * This byteCode is invalid: free it and recompile.
- */
-
- objPtr->typePtr->freeIntRepProc(objPtr);
+ 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
- * because it eval-directs any literals, so just saving the argument
- * locations per command in bytecode is enough, embedded 'eval'
- * commands, etc. get the correct information.
- *
- * It had be backported for 8.5 because we can force the separate
- * compiling of a literal (in a proc body) by putting it into a control
- * command with dynamic pieces, and then such literal may be shared
- * and require their line-information to be reset, as for 8.6, as
- * described below.
+ * 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.
*
- * In 8.6 all the embedded script are compiled, and the resulting
+ * 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
@@ -1472,77 +1719,67 @@ TclCompEvalObj(
* information.
*/
- if (invoker) {
+ if (invoker == NULL) {
+ return codePtr;
+ } else {
Tcl_HashEntry *hePtr =
- Tcl_FindHashEntry(iPtr->lineBCPtr, (char *) codePtr);
+ Tcl_FindHashEntry(iPtr->lineBCPtr, codePtr);
+ ExtCmdLoc *eclPtr;
+ CmdFrame *ctxCopyPtr;
+ int redo;
- if (hePtr) {
- ExtCmdLoc *eclPtr = Tcl_GetHashValue(hePtr);
- int redo = 0;
- CmdFrame *ctxPtr = TclStackAlloc(interp,sizeof(CmdFrame));
+ if (!hePtr) {
+ return codePtr;
+ }
- *ctxPtr = *invoker;
+ 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(ctxPtr);
- if (ctxPtr->type == TCL_LOCATION_SOURCE) {
- /*
- * The reference made by 'TclGetSrcInfoForPc' is
- * dead.
- */
-
- Tcl_DecrRefCount(ctxPtr->data.eval.path);
- ctxPtr->data.eval.path = NULL;
- }
- }
-
- if (word < ctxPtr->nline) {
+ 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) {
/*
- * 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 ...).
+ * The reference made by 'TclGetSrcInfoForPc' is dead.
*/
-
- redo = ((eclPtr->type == TCL_LOCATION_SOURCE)
- && (eclPtr->start != ctxPtr->line[word]))
- || ((eclPtr->type == TCL_LOCATION_BC)
- && (ctxPtr->type == TCL_LOCATION_SOURCE));
- }
-
- TclStackFree(interp, ctxPtr);
-
- if (redo) {
- goto recompileObj;
+
+ Tcl_DecrRefCount(ctxCopyPtr->data.eval.path);
+ ctxCopyPtr->data.eval.path = NULL;
}
}
- }
- /*
- * Increment the code's ref count while it is being executed. If
- * afterwards no references to it remain, free the code.
- */
+ if (word < ctxCopyPtr->nline) {
+ /*
+ * Note: We do not care if the line[word] is -1. This is a
+ * difference and requires a recompile (location changed from
+ * absolute to relative, literal is used fixed and through
+ * variable)
+ *
+ * Example:
+ * test info-32.0 using literal of info-24.8
+ * (dict with ... vs set body ...).
+ */
+
+ redo = ((eclPtr->type == TCL_LOCATION_SOURCE)
+ && (eclPtr->start != ctxCopyPtr->line[word]))
+ || ((eclPtr->type == TCL_LOCATION_BC)
+ && (ctxCopyPtr->type == TCL_LOCATION_SOURCE));
+ }
- runCompiledObj:
- codePtr->refCount++;
- result = TclExecuteByteCode(interp, codePtr);
- codePtr->refCount--;
- if (codePtr->refCount <= 0) {
- TclCleanupByteCode(codePtr);
+ TclStackFree(interp, ctxCopyPtr);
+ if (!redo) {
+ return codePtr;
+ }
}
- goto done;
}
- recompileObj:
+ recompileObj:
iPtr->errorLine = 1;
/*
@@ -1554,14 +1791,14 @@ TclCompEvalObj(
iPtr->invokeCmdFramePtr = invoker;
iPtr->invokeWord = word;
- tclByteCodeType.setFromAnyProc(interp, objPtr);
+ TclSetByteCodeFromAny(interp, objPtr, NULL, NULL);
iPtr->invokeCmdFramePtr = NULL;
- codePtr = (ByteCode *) objPtr->internalRep.twoPtrValue.ptr1;
- goto runCompiledObj;
-
- done:
- iPtr->numLevels--;
- return result;
+ codePtr = objPtr->internalRep.twoPtrValue.ptr1;
+ if (iPtr->varFramePtr->localCachePtr) {
+ codePtr->localCachePtr = iPtr->varFramePtr->localCachePtr;
+ codePtr->localCachePtr->refCount++;
+ }
+ return codePtr;
}
/*
@@ -1630,7 +1867,7 @@ TclIncrObj(
TclSetLongObj(valuePtr, sum);
return TCL_OK;
}
-#ifndef NO_WIDE_TYPE
+#ifndef TCL_WIDE_INT_IS_LONG
{
Tcl_WideInt w1 = (Tcl_WideInt) augend;
Tcl_WideInt w2 = (Tcl_WideInt) addend;
@@ -1663,7 +1900,7 @@ TclIncrObj(
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;
@@ -1693,7 +1930,7 @@ TclIncrObj(
/*
*----------------------------------------------------------------------
*
- * TclExecuteByteCode --
+ * TclNRExecuteByteCode --
*
* This procedure executes the instructions of a ByteCode structure. It
* returns when a "done" instruction is executed or an error occurs.
@@ -1708,12 +1945,89 @@ TclIncrObj(
*
*----------------------------------------------------------------------
*/
+#define bcFramePtr (&TD->cmdFrame)
+#define initCatchTop ((ptrdiff_t *) (&TD->stack[-1]))
+#define initTosPtr ((Tcl_Obj **) (initCatchTop+codePtr->maxExceptDepth))
+#define esPtr (iPtr->execEnvPtr->execStackPtr)
int
-TclExecuteByteCode(
+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 *);
+
+ if (iPtr->execEnvPtr->rewind) {
+ return TCL_ERROR;
+ }
+
+ codePtr->refCount++;
+
+ /*
+ * Reserve the stack, setup the TEBCdataPtr (TD) and CallFrame
+ *
+ * The execution uses a unified stack: first a TEBCdata, immediately
+ * above it a CmdFrame, then the catch stack, then the execution stack.
+ *
+ * Make sure the catch stack is large enough to hold the maximum number of
+ * catch commands that could ever be executing at the same time (this will
+ * be no more than the exception range array's depth). Make sure the
+ * execution stack is large enough to execute this ByteCode.
+ */
+
+ TD = (TEBCdata *) GrowEvaluationStack(iPtr->execEnvPtr, numWords, 0);
+ esPtr->tosPtr = initTosPtr;
+
+ TD->codePtr = codePtr;
+ TD->pc = codePtr->codeStart;
+ TD->catchTop = initCatchTop;
+ TD->cleanup = 0;
+ TD->auxObjList = NULL;
+ TD->checkInterp = 0;
+
+ /*
+ * TIP #280: Initialize the frame. Do not push it yet: it will be pushed
+ * every time that we call out from this TD, popped when we return to it.
+ */
+
+ bcFramePtr->type = ((codePtr->flags & TCL_BYTECODE_PRECOMPILED)
+ ? TCL_LOCATION_PREBC : TCL_LOCATION_BC);
+ bcFramePtr->level = (iPtr->cmdFramePtr ? iPtr->cmdFramePtr->level+1 : 1);
+ bcFramePtr->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, /*resume*/ INT2PTR(0),
+ NULL, NULL);
+ return TCL_OK;
+}
+
+static int
+TEBCresume(
+ ClientData data[],
+ Tcl_Interp *interp,
+ int result)
+{
/*
* Compiler cast directive - not a real variable.
* Interp *iPtr = (Interp *) interp;
@@ -1726,111 +2040,158 @@ TclExecuteByteCode(
#define ReadTraced(varPtr) ((varPtr)->flags & VAR_TRACED_READ)
#define WriteTraced(varPtr) ((varPtr)->flags & VAR_TRACED_WRITE)
+#define UnsetTraced(varPtr) ((varPtr)->flags & VAR_TRACED_UNSET)
+
+ /*
+ * Bottom of allocated stack holds the NR data
+ */
/*
* Constants: variables that do not change during the execution, used
- * sporadically.
+ * sporadically: no special need for speed.
*/
- ExecStack *esPtr;
- Tcl_Obj **initTosPtr; /* Stack top at start of execution. */
- ptrdiff_t *initCatchTop; /* Catch stack top at start of execution. */
- Var *compiledLocals;
- Namespace *namespacePtr;
- CmdFrame *bcFramePtr; /* TIP #280: Structure for tracking lines. */
+ int instructionCount = 0; /* Counter that is used to work out when to
+ * call Tcl_AsyncReady() */
+ const char *curInstName;
+#ifdef TCL_COMPILE_DEBUG
+ int traceInstructions; /* Whether we are doing instruction-level
+ * tracing or not. */
+#endif
+
+ Var *compiledLocals = iPtr->varFramePtr->compiledLocals;
Tcl_Obj **constants = &iPtr->execEnvPtr->constants[0];
+#define LOCAL(i) (&compiledLocals[(i)])
+#define TCONST(i) (constants[(i)])
+
+ /*
+ * These macros are just meant to save some global variables that are not
+ * used too frequently
+ */
+
+ TEBCdata *TD = data[0];
+#define auxObjList (TD->auxObjList)
+#define catchTop (TD->catchTop)
+#define codePtr (TD->codePtr)
+#define checkInterp (TD->checkInterp)
+ /* Indicates when a check of interp readyness is
+ * necessary. Set by CACHE_STACK_INFO() */
+
/*
* Globals: variables that store state, must remain valid at all times.
*/
- ptrdiff_t *catchTop;
- register Tcl_Obj **tosPtr; /* Cached pointer to top of evaluation
+ 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 CACHE_STACK_INFO() */
-
+ const unsigned char *pc; /* The current program counter. */
+ unsigned char inst; /* The currently running instruction */
+
/*
* Transfer variables - needed only between opcodes, but not while
* executing an instruction.
*/
- register int cleanup;
+ int cleanup = 0;
Tcl_Obj *objResultPtr;
/*
- * Result variable - needed only when going to checkForcatch or other
- * error handlers; also used as local in some opcodes.
- */
-
- int result = TCL_OK; /* Return code returned after execution. */
-
- /*
* Locals - variables that are used within opcodes or bounded sections of
* the file (jumps between opcodes within a family).
- * NOTE: These are now 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
- char *curInstName = NULL;
-
- /*
- * The execution uses a unified stack: first the catch stack, immediately
- * above it a CmdFrame, then the execution stack.
- *
- * Make sure the catch stack is large enough to hold the maximum number of
- * catch commands that could ever be executing at the same time (this will
- * be no more than the exception range array's depth). Make sure the
- * execution stack is large enough to execute this ByteCode.
- */
- catchTop = initCatchTop = (ptrdiff_t *) (
- GrowEvaluationStack(iPtr->execEnvPtr,
- (sizeof(CmdFrame) + sizeof(Tcl_Obj *) - 1)/sizeof(Tcl_Obj *) +
- codePtr->maxExceptDepth + codePtr->maxStackDepth, 0) - 1);
- bcFramePtr = (CmdFrame *) (initCatchTop + codePtr->maxExceptDepth + 1);
- tosPtr = initTosPtr = ((Tcl_Obj **) (bcFramePtr + 1)) - 1;
- esPtr = iPtr->execEnvPtr->execStackPtr;
-
- /*
- * TIP #280: Initialize the frame. Do not push it yet.
- */
-
- bcFramePtr->type = ((codePtr->flags & TCL_BYTECODE_PRECOMPILED)
- ? TCL_LOCATION_PREBC : TCL_LOCATION_BC);
- bcFramePtr->level = (iPtr->cmdFramePtr ? iPtr->cmdFramePtr->level+1 : 1);
- bcFramePtr->framePtr = iPtr->framePtr;
- bcFramePtr->nextPtr = iPtr->cmdFramePtr;
- bcFramePtr->nline = 0;
- bcFramePtr->line = NULL;
+#ifdef TCL_COMPILE_DEBUG
+ int starting = 1;
+ traceInstructions = (tclTraceExec == 3);
+#endif
- bcFramePtr->data.tebc.codePtr = codePtr;
- bcFramePtr->data.tebc.pc = NULL;
- bcFramePtr->cmd.str.cmd = NULL;
- bcFramePtr->cmd.str.len = 0;
+ TEBC_DATA_DIG();
#ifdef TCL_COMPILE_DEBUG
- if (tclTraceExec >= 2) {
+ if (!data[1] && (tclTraceExec >= 2)) {
PrintByteCodeInfo(codePtr);
fprintf(stdout, " Starting stack top=%d\n", (int) CURR_DEPTH);
fflush(stdout);
}
#endif
-#ifdef TCL_COMPILE_STATS
- iPtr->stats.numExecutions++;
+ if (data[1] /* resume from invocation */) {
+ if (iPtr->execEnvPtr->rewind) {
+ result = TCL_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((Tcl_Interp *) iPtr, bcFramePtr);
+ }
+ if (codePtr->flags & TCL_BYTECODE_RECOMPILE) {
+ iPtr->flags |= ERR_ALREADY_LOGGED;
+ codePtr->flags &= ~TCL_BYTECODE_RECOMPILE;
+ }
+
+ CACHE_STACK_INFO();
+ if (result == TCL_OK) {
+ /*
+ * 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);
+ }
- namespacePtr = iPtr->varFramePtr->nsPtr;
- compiledLocals = iPtr->varFramePtr->compiledLocals;
+ /*
+ * Result not TCL_OK: fall through
+ */
+ }
+
+ if (iPtr->execEnvPtr->rewind) {
+ result = TCL_ERROR;
+ goto abnormalReturn;
+ }
+
+ if (result != TCL_OK) {
+ pc--;
+ goto processExceptionReturn;
+ }
/*
* Loop executing instructions until a "done" instruction, a TCL_RETURN,
@@ -1848,76 +2209,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 = OBJ_AT_TOS;
- TclDecrRefCount(valuePtr);
- }
- OBJ_AT_TOS = 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, CURR_DEPTH, 0,
- /*checkStack*/ expandNestList == NULL);
- if (traceInstructions) {
- fprintf(stdout, "%2d: %2d ", iPtr->numLevels, (int) CURR_DEPTH);
- 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
@@ -1925,37 +2264,31 @@ TclExecuteByteCode(
*/
if ((instructionCount++ & ASYNC_CHECK_COUNT_MASK) == 0) {
- /*
- * Check for asynchronous handlers [Bug 746722]; we do the check every
- * ASYNC_CHECK_COUNT_MASK instruction, of the form (2**n-<1).
- */
-
+ DECACHE_STACK_INFO();
if (TclAsyncReady(iPtr)) {
- int localResult;
+ 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 (TclLimitReady(iPtr->limit)) {
- 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();
}
- TCL_DTRACE_INST_NEXT();
-
/*
* These two instructions account for 26% of all instructions (according
* to measurements on tclbench by Ben Vitale
@@ -1965,13 +2298,62 @@ TclExecuteByteCode(
* reduces total obj size.
*/
- if (*pc == INST_LOAD_SCALAR1) {
- goto instLoadScalar1;
- } else if (*pc == INST_PUSH1) {
- goto instPush1Peephole;
+ 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);
@@ -1984,34 +2366,139 @@ TclExecuteByteCode(
TRACE(("%u %u => ", code, level));
result = TclProcessReturn(interp, code, level, OBJ_AT_TOS);
if (result == TCL_OK) {
- TRACE_APPEND(("continuing to next instruction (result=\"%.30s\")",
+ TRACE_APPEND(("continuing to next instruction (result=\"%.30s\")\n",
O2S(objResultPtr)));
NEXT_INST_F(9, 1, 0);
- } else {
- Tcl_SetObjResult(interp, OBJ_UNDER_TOS);
- if (*pc == INST_SYNTAX) {
- iPtr->flags &= ~ERR_ALREADY_LOGGED;
- }
- cleanup = 2;
- goto processExceptionReturn;
}
+ Tcl_SetObjResult(interp, OBJ_UNDER_TOS);
+ if (*pc == INST_SYNTAX) {
+ iPtr->flags &= ~ERR_ALREADY_LOGGED;
+ }
+ cleanup = 2;
+ TRACE_APPEND(("\n"));
+ goto processExceptionReturn;
}
case INST_RETURN_STK:
TRACE(("=> "));
objResultPtr = POP_OBJECT();
result = Tcl_SetReturnOptions(interp, OBJ_AT_TOS);
- Tcl_DecrRefCount(OBJ_AT_TOS);
- OBJ_AT_TOS = objResultPtr;
if (result == TCL_OK) {
- TRACE_APPEND(("continuing to next instruction (result=\"%.30s\")",
+ 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);
- cleanup = 1;
- goto processExceptionReturn;
}
+ cleanup = 1;
+ TRACE_APPEND(("\n"));
+ goto processExceptionReturn;
+
+ case INST_YIELD: {
+ CoroutineData *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));
+ Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "ILLEGAL_YIELD",
+ NULL);
+ goto gotError;
+ }
+
+#ifdef TCL_COMPILE_DEBUG
+ TRACE_WITH_OBJ(("yield, result="), iPtr->objResultPtr);
+ if (traceInstructions) {
+ fprintf(stdout, "\n");
+ }
+#endif
+ /* TIP #280: Record the last piece of info needed by
+ * 'TclGetSrcInfoForPc', and push the frame.
+ */
+
+ bcFramePtr->data.tebc.pc = (char *) pc;
+ iPtr->cmdFramePtr = bcFramePtr;
+
+ if (iPtr->flags & INTERP_DEBUG_FRAME) {
+ int cmd;
+ if (GetSrcInfoForPc(pc, codePtr, NULL, NULL, &cmd)) {
+ TclArgumentBCEnter((Tcl_Interp *) iPtr, objv, objc,
+ codePtr, bcFramePtr, cmd, pc - codePtr->codeStart);
+ }
+ }
+
+ pc++;
+ cleanup = 1;
+ TEBC_YIELD();
+
+ Tcl_SetObjResult(interp, OBJ_AT_TOS);
+ TclNRAddCallback(interp, TclNRCoroutineActivateCallback, corPtr,
+ INT2PTR(0), NULL, NULL);
+
+ return TCL_OK;
+ }
+
+ case INST_TAILCALL: {
+ Tcl_Obj *listPtr, *nsObjPtr;
+
+ opnd = TclGetUInt1AtPtr(pc+1);
+
+ if (!(iPtr->varFramePtr->isProcCallFrame & 1)) {
+ TRACE(("%d => ERROR: tailcall in non-proc context\n", opnd));
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "tailcall can only be called from a proc or lambda", -1));
+ Tcl_SetErrorCode(interp, "TCL", "TAILCALL", "ILLEGAL", NULL);
+ goto gotError;
+ }
+
+#ifdef TCL_COMPILE_DEBUG
+ {
+ 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
+
+ /*
+ * Push the evaluation of the called command into the NR callback
+ * stack.
+ */
+
+ listPtr = Tcl_NewListObj(opnd, &OBJ_AT_DEPTH(opnd-1));
+ nsObjPtr = Tcl_NewStringObj(iPtr->varFramePtr->nsPtr->fullName, -1);
+ TclListObjSetElement(interp, listPtr, 0, nsObjPtr);
+ if (iPtr->varFramePtr->tailcallPtr) {
+ Tcl_DecrRefCount(iPtr->varFramePtr->tailcallPtr);
+ }
+ iPtr->varFramePtr->tailcallPtr = listPtr;
+
+ result = TCL_RETURN;
+ cleanup = opnd;
+ goto processExceptionReturn;
+ }
case INST_DONE:
if (tosPtr > initTosPtr) {
@@ -2031,153 +2518,90 @@ TclExecuteByteCode(
}
#endif
goto checkForCatch;
- } else {
- (void) POP_OBJECT();
- goto abnormalReturn;
- }
-
- case INST_PUSH1:
- instPush1Peephole:
- PUSH_OBJECT(codePtr->objArrayPtr[TclGetUInt1AtPtr(pc+1)]);
- TRACE_WITH_OBJ(("%u => ", TclGetInt1AtPtr(pc+1)), OBJ_AT_TOS);
- pc += 2;
-#if !TCL_COMPILE_DEBUG
- /*
- * Runtime peephole optimisation: check if we are pushing again.
- */
-
- if (*pc == INST_PUSH1) {
- TCL_DTRACE_INST_NEXT();
- goto instPush1Peephole;
}
-#endif
- NEXT_INST_F(0, 0, 0);
+ (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: {
- Tcl_Obj *valuePtr;
-
+ case INST_POP:
TRACE_WITH_OBJ(("=> discarding "), OBJ_AT_TOS);
- valuePtr = POP_OBJECT();
- TclDecrRefCount(valuePtr);
-
- /*
- * Runtime peephole optimisation: an INST_POP is scheduled at the end
- * of most commands. If the next instruction is an INST_START_CMD,
- * fall through to it.
- */
-
- pc++;
-#if !TCL_COMPILE_DEBUG
- if (*pc == INST_START_CMD) {
- TCL_DTRACE_INST_NEXT();
- goto instStartCmdPeephole;
- }
-#endif
- NEXT_INST_F(0, 0, 0);
- }
-
- case INST_START_CMD:
-#if !TCL_COMPILE_DEBUG
- instStartCmdPeephole:
-#endif
- /*
- * Remark that if the interpreter is marked for deletion its
- * compileEpoch is modified, so that the epoch check also verifies
- * that the interp is not deleted. If no outside call has been made
- * since the last check, it is safe to omit the check.
- */
-
- iPtr->cmdCount += TclGetUInt4AtPtr(pc+5);
- if (!checkInterp) {
- instStartCmdOK:
- NEXT_INST_F(9, 0, 0);
- } else if (((codePtr->compileEpoch == iPtr->compileEpoch)
- && (codePtr->nsEpoch == namespacePtr->resolverEpoch))
- || (codePtr->flags & TCL_BYTECODE_PRECOMPILED)) {
- checkInterp = 0;
- goto instStartCmdOK;
- } else {
- const char *bytes;
- int length, opnd;
- Tcl_Obj *newObjResultPtr;
-
- bytes = GetSrcInfoForPc(pc, codePtr, &length);
- DECACHE_STACK_INFO();
- result = Tcl_EvalEx(interp, bytes, length, 0);
- CACHE_STACK_INFO();
- if (result != TCL_OK) {
- cleanup = 0;
- if (result == TCL_ERROR) {
- /*
- * Tcl_EvalEx already did the task of logging
- * the error to the stack trace for us, so set
- * a flag to prevent the TEBC exception handling
- * machinery from trying to do it again.
- * Tcl Bug 2037338. See test execute-8.4.
- */
- iPtr->flags |= ERR_ALREADY_LOGGED;
- }
- goto processExceptionReturn;
- }
- opnd = TclGetUInt4AtPtr(pc+1);
- objResultPtr = Tcl_GetObjResult(interp);
- TclNewObj(newObjResultPtr);
- Tcl_IncrRefCount(newObjResultPtr);
- iPtr->objResultPtr = newObjResultPtr;
- NEXT_INST_V(opnd, 0, -1);
- }
+ objPtr = POP_OBJECT();
+ TclDecrRefCount(objPtr);
+ NEXT_INST_F(1, 0, 0);
case INST_DUP:
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 = OBJ_AT_DEPTH(opnd);
TRACE_WITH_OBJ(("=> "), objResultPtr);
NEXT_INST_F(5, 0, 1);
- }
case INST_REVERSE: {
- int opnd;
Tcl_Obj **a, **b;
opnd = TclGetUInt4AtPtr(pc+1);
a = tosPtr-(opnd-1);
b = tosPtr;
while (a<b) {
- Tcl_Obj *temp = *a;
+ tmpPtr = *a;
*a = *b;
- *b = temp;
+ *b = tmpPtr;
a++; b--;
}
NEXT_INST_F(5, 0, 0);
}
case INST_CONCAT1: {
- int opnd, length, appendLen = 0;
+ 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=&OBJ_AT_DEPTH(opnd-2);
- appendLen >= 0 && currPtr<=&OBJ_AT_TOS; currPtr++) {
- bytes = TclGetStringFromObj(*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;
+ }
}
}
@@ -2208,50 +2632,85 @@ TclExecuteByteCode(
*/
objResultPtr = OBJ_AT_DEPTH(opnd-1);
- bytes = TclGetStringFromObj(objResultPtr, &length);
- if (length + appendLen < 0) {
- /* TODO: convert panic to error ? */
- Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX);
- }
-#if !TCL_COMPILE_DEBUG
- if (bytes != tclEmptyStringRep && !Tcl_IsShared(objResultPtr)) {
- TclFreeIntRep(objResultPtr);
- objResultPtr->typePtr = NULL;
- objResultPtr->bytes = ckrealloc(bytes, (length + appendLen + 1));
- objResultPtr->length = length + appendLen;
- p = TclGetString(objResultPtr) + length;
- currPtr = &OBJ_AT_DEPTH(opnd - 2);
- } else {
+ 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 = &OBJ_AT_DEPTH(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 <= &OBJ_AT_TOS; currPtr++) {
- bytes = TclGetStringFromObj(*currPtr, &length);
- if (bytes != NULL) {
- memcpy(p, 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_EXPAND_START:
/*
- * Push an element to the expandNestList. This records the current
+ * Push an element to the auxObjList. This records the current
* stack depth - i.e., the point in the stack where the expanded
* command starts.
*
@@ -2263,18 +2722,30 @@ TclExecuteByteCode(
* error, also in INST_EXPAND_STKTOP).
*/
- Tcl_Obj *objPtr;
-
TclNewObj(objPtr);
- objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) CURR_DEPTH;
- objPtr->internalRep.twoPtrValue.ptr2 = (VOID *) expandNestList;
- expandNestList = objPtr;
+ objPtr->internalRep.ptrAndLongRep.value = CURR_DEPTH;
+ objPtr->length = 0;
+ PUSH_TAUX_OBJ(objPtr);
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
+ NEXT_INST_V(1, objc, 0);
case INST_EXPAND_STKTOP: {
- int objc, length, i;
- Tcl_Obj **objv, *valuePtr;
+ int i;
ptrdiff_t moved;
/*
@@ -2283,12 +2754,11 @@ TclExecuteByteCode(
* will be removed at checkForCatch.
*/
- valuePtr = OBJ_AT_TOS;
- if (TclListObjGetElements(interp, valuePtr, &objc, &objv) != TCL_OK){
- TRACE_WITH_OBJ(("%.30s => ERROR: ", O2S(valuePtr)),
+ objPtr = OBJ_AT_TOS;
+ if (TclListObjGetElements(interp, objPtr, &objc, &objv) != TCL_OK) {
+ TRACE_WITH_OBJ(("%.30s => ERROR: ", O2S(objPtr)),
Tcl_GetObjResult(interp));
- result = TCL_ERROR;
- goto checkForCatch;
+ goto gotError;
}
(void) POP_OBJECT();
@@ -2299,22 +2769,27 @@ TclExecuteByteCode(
* stack depth, as seen by the compiler.
*/
- length = objc + (codePtr->maxStackDepth - TclGetInt4AtPtr(pc+1));
- DECACHE_STACK_INFO();
- moved = (GrowEvaluationStack(iPtr->execEnvPtr, length, 1) - 1)
- - (Tcl_Obj **) initCatchTop;
+ 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();
+ 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.
+ */
- if (moved) {
- /*
- * Change the global data to point to the new stack.
- */
+ esPtr = iPtr->execEnvPtr->execStackPtr;
+ TD = (TEBCdata *) (((Tcl_Obj **)TD) + moved);
- initCatchTop += moved;
- catchTop += moved;
- bcFramePtr = (CmdFrame *) (initCatchTop + codePtr->maxExceptDepth + 1);
- initTosPtr += moved;
- tosPtr += moved;
- esPtr = iPtr->execEnvPtr->execStackPtr;
+ catchTop += moved;
+ tosPtr += moved;
+ }
}
/*
@@ -2326,39 +2801,54 @@ TclExecuteByteCode(
PUSH_OBJECT(objv[i]);
}
- Tcl_DecrRefCount(valuePtr);
+ 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 = expandNestList;
-
- expandNestList = (Tcl_Obj *) objPtr->internalRep.twoPtrValue.ptr2;
- objc = CURR_DEPTH
- - (ptrdiff_t) objPtr->internalRep.twoPtrValue.ptr1;
- TclDecrRefCount(objPtr);
- }
+ cleanup = 1;
+ pc += 1;
+ TEBC_YIELD();
+ return TclNREvalObjEx(interp, OBJ_AT_TOS, 0, NULL, 0);
+ case INST_INVOKE_EXPANDED:
+ CLANG_ASSERT(auxObjList);
+ objc = CURR_DEPTH - auxObjList->internalRep.ptrAndLongRep.value;
+ POP_TAUX_OBJ();
if (objc) {
pcAdjustment = 1;
goto doInvocation;
- } else {
- /*
- * Nothing was expanded, return {}.
- */
-
- TclNewObj(objResultPtr);
- NEXT_INST_F(1, 0, 1);
}
+ /*
+ * Nothing was expanded, return {}.
+ */
+
+ TclNewObj(objResultPtr);
+ NEXT_INST_F(1, 0, 1);
+
case INST_INVOKE_STK4:
objc = TclGetUInt4AtPtr(pc+1);
pcAdjustment = 5;
@@ -2369,103 +2859,56 @@ TclExecuteByteCode(
pcAdjustment = 2;
doInvocation:
- {
- Tcl_Obj **objv = &OBJ_AT_DEPTH(objc-1);
+ objv = &OBJ_AT_DEPTH(objc-1);
+ cleanup = objc;
#ifdef TCL_COMPILE_DEBUG
- if (tclTraceExec >= 2) {
- int i;
+ 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)(pc - codePtr->codeStart));
- }
- for (i = 0; i < objc; i++) {
- TclPrintObject(stdout, objv[i], 15);
- fprintf(stdout, " ");
- }
- fprintf(stdout, "\n");
- fflush(stdout);
+ if (traceInstructions) {
+ strncpy(cmdNameBuf, TclGetString(objv[0]), 20);
+ TRACE(("%u => call ", objc));
+ } else {
+ fprintf(stdout, "%d: (%u) invoking ", iPtr->numLevels,
+ (unsigned)(pc - codePtr->codeStart));
}
+ for (i = 0; i < objc; i++) {
+ TclPrintObject(stdout, objv[i], 15);
+ fprintf(stdout, " ");
+ }
+ fprintf(stdout, "\n");
+ fflush(stdout);
+ }
#endif /*TCL_COMPILE_DEBUG*/
- /*
- * 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.
- *
- * TIP #280: Record the last piece of info needed by
- * 'TclGetSrcInfoForPc', and push the frame.
- */
+ bcFramePtr->data.tebc.pc = (char *) pc;
+ iPtr->cmdFramePtr = bcFramePtr;
- bcFramePtr->data.tebc.pc = (char *) pc;
- iPtr->cmdFramePtr = bcFramePtr;
- if (iPtr->flags & INTERP_DEBUG_FRAME) {
+ if (iPtr->flags & INTERP_DEBUG_FRAME) {
+ int cmd;
+ if (GetSrcInfoForPc(pc, codePtr, NULL, NULL, &cmd)) {
TclArgumentBCEnter((Tcl_Interp *) iPtr, objv, objc,
- codePtr, bcFramePtr, pc - codePtr->codeStart);
- }
- DECACHE_STACK_INFO();
- result = TclEvalObjvInternal(interp, objc, objv,
- /* call from TEBC */(char *) -1, -1, 0);
- CACHE_STACK_INFO();
- if (iPtr->flags & INTERP_DEBUG_FRAME) {
- TclArgumentBCRelease((Tcl_Interp *) iPtr, objv, objc,
- codePtr, pc - codePtr->codeStart);
+ codePtr, bcFramePtr, cmd, pc - codePtr->codeStart);
}
- iPtr->cmdFramePtr = iPtr->cmdFramePtr->nextPtr;
-
- if (result == TCL_OK) {
- Tcl_Obj *objPtr;
-
- /*
- * Push the call's object result and continue execution with
- * the next instruction.
- */
-
- TRACE_WITH_OBJ(("%u => ... after \"%.20s\": TCL_OK, result=",
- objc, cmdNameBuf), Tcl_GetObjResult(interp));
-
- objResultPtr = Tcl_GetObjResult(interp);
+ }
- /*
- * Reset the interp's result to avoid possible duplications of
- * large objects [Bug 781585]. We do not call Tcl_ResetResult
- * to avoid any side effects caused by the resetting of
- * errorInfo and errorCode [Bug 804681], which are not needed
- * here. We chose instead to manipulate the interp's object
- * result directly.
- *
- * Note that the result object is now in objResultPtr, it
- * keeps the refCount it had in its role of
- * iPtr->objResultPtr.
- */
+ DECACHE_STACK_INFO();
- TclNewObj(objPtr);
- Tcl_IncrRefCount(objPtr);
- iPtr->objResultPtr = objPtr;
-#ifndef TCL_COMPILE_DEBUG
- if (*(pc+pcAdjustment) == INST_POP) {
- TclDecrRefCount(objResultPtr);
- NEXT_INST_V((pcAdjustment+1), objc, 0);
- }
-#endif
- NEXT_INST_V(pcAdjustment, objc, -1);
- } else {
- cleanup = objc;
- goto processExceptionReturn;
- }
- }
+ pc += pcAdjustment;
+ TEBC_YIELD();
+ return TclNREvalObjv(interp, objc, objv,
+ TCL_EVAL_NOERR | TCL_EVAL_SOURCE_IN_FRAME, NULL);
#if TCL_SUPPORT_84_BYTECODE
- case INST_CALL_BUILTIN_FUNC1: {
+ case INST_CALL_BUILTIN_FUNC1:
/*
* Call one of the built-in pre-8.5 Tcl math functions. This
* translates to INST_INVOKE_STK1 with the first argument of
@@ -2473,47 +2916,45 @@ TclExecuteByteCode(
* function into the stack.
*/
- int opnd, numArgs;
- Tcl_Obj *objPtr;
-
opnd = TclGetUInt1AtPtr(pc+1);
if ((opnd < 0) || (opnd > LAST_BUILTIN_FUNC)) {
TRACE(("UNRECOGNIZED BUILTIN FUNC CODE %d\n", opnd));
- Tcl_Panic("TclExecuteByteCode: unrecognized builtin function code %d", opnd);
+ Tcl_Panic("TclNRExecuteByteCode: unrecognized builtin function code %d", opnd);
}
- objPtr = Tcl_NewStringObj("::tcl::mathfunc::", 17);
+ TclNewLiteralStringObj(objPtr, "::tcl::mathfunc::");
Tcl_AppendToObj(objPtr, tclBuiltinFuncTable[opnd].name, -1);
/*
* Only 0, 1 or 2 args.
*/
- numArgs = tclBuiltinFuncTable[opnd].numArgs;
- if (numArgs == 0) {
- PUSH_OBJECT(objPtr);
- } else if (numArgs == 1) {
- Tcl_Obj *tmpPtr1 = POP_OBJECT();
- PUSH_OBJECT(objPtr);
- PUSH_OBJECT(tmpPtr1);
- Tcl_DecrRefCount(tmpPtr1);
- } else {
+ {
+ int numArgs = tclBuiltinFuncTable[opnd].numArgs;
Tcl_Obj *tmpPtr1, *tmpPtr2;
- tmpPtr2 = POP_OBJECT();
- tmpPtr1 = POP_OBJECT();
- PUSH_OBJECT(objPtr);
- PUSH_OBJECT(tmpPtr1);
- PUSH_OBJECT(tmpPtr2);
- Tcl_DecrRefCount(tmpPtr1);
- Tcl_DecrRefCount(tmpPtr2);
- }
- objc = numArgs + 1;
+ if (numArgs == 0) {
+ PUSH_OBJECT(objPtr);
+ } else if (numArgs == 1) {
+ tmpPtr1 = POP_OBJECT();
+ PUSH_OBJECT(objPtr);
+ PUSH_OBJECT(tmpPtr1);
+ Tcl_DecrRefCount(tmpPtr1);
+ } else {
+ tmpPtr2 = POP_OBJECT();
+ tmpPtr1 = POP_OBJECT();
+ PUSH_OBJECT(objPtr);
+ PUSH_OBJECT(tmpPtr1);
+ PUSH_OBJECT(tmpPtr2);
+ Tcl_DecrRefCount(tmpPtr1);
+ Tcl_DecrRefCount(tmpPtr2);
+ }
+ objc = numArgs + 1;
+ }
pcAdjustment = 2;
goto doInvocation;
- }
- case INST_CALL_FUNC1: {
+ case INST_CALL_FUNC1:
/*
* Call a non-builtin Tcl math function previously registered by a
* call to Tcl_CreateMathFunc pre-8.5. This is essentially
@@ -2521,16 +2962,11 @@ TclExecuteByteCode(
* ::tcl::mathfunc::$objv[0].
*/
- Tcl_Obj *tmpPtr, *objPtr;
-
- /*
- * Number of arguments. The function name is the 0-th argument.
- */
-
- objc = TclGetUInt1AtPtr(pc+1);
+ objc = TclGetUInt1AtPtr(pc+1); /* Number of arguments. The function
+ * name is the 0-th argument. */
objPtr = OBJ_AT_DEPTH(objc-1);
- tmpPtr = Tcl_NewStringObj("::tcl::mathfunc::", 17);
+ TclNewLiteralStringObj(tmpPtr, "::tcl::mathfunc::");
Tcl_AppendObjToObj(tmpPtr, objPtr);
Tcl_DecrRefCount(objPtr);
@@ -2543,7 +2979,6 @@ TclExecuteByteCode(
pcAdjustment = 2;
goto doInvocation;
- }
#else
/*
* INST_CALL_BUILTIN_FUNC1 and INST_CALL_FUNC1 were made obsolete by the
@@ -2552,98 +2987,91 @@ TclExecuteByteCode(
*/
case INST_CALL_BUILTIN_FUNC1:
- Tcl_Panic("TclExecuteByteCode: obsolete INST_CALL_BUILTIN_FUNC1 found");
+ Tcl_Panic("TclNRExecuteByteCode: obsolete INST_CALL_BUILTIN_FUNC1 found");
case INST_CALL_FUNC1:
- Tcl_Panic("TclExecuteByteCode: obsolete INST_CALL_FUNC1 found");
+ Tcl_Panic("TclNRExecuteByteCode: obsolete INST_CALL_FUNC1 found");
#endif
- }
-
- case INST_EVAL_STK: {
- /*
- * Note to maintainers: it is important that INST_EVAL_STK pop its
- * argument from the stack before jumping to checkForCatch! DO NOT
- * OPTIMISE!
- */
-
- Tcl_Obj *objPtr = OBJ_AT_TOS;
-
- DECACHE_STACK_INFO();
-
- /*
- * TIP #280: The invoking context is left NULL for a dynamically
- * constructed command. We cannot match its lines to the outer
- * context.
- */
-
- result = TclCompEvalObj(interp, objPtr, NULL, 0);
- CACHE_STACK_INFO();
- if (result == TCL_OK) {
- /*
- * Normal return; push the eval's object result.
- */
-
- objResultPtr = Tcl_GetObjResult(interp);
- TRACE_WITH_OBJ(("\"%.30s\" => ", O2S(objPtr)),
- Tcl_GetObjResult(interp));
- /*
- * Reset the interp's result to avoid possible duplications of
- * large objects [Bug 781585]. We do not call Tcl_ResetResult to
- * avoid any side effects caused by the resetting of errorInfo and
- * errorCode [Bug 804681], which are not needed here. We chose
- * instead to manipulate the interp's object result directly.
- *
- * Note that the result object is now in objResultPtr, it keeps
- * the refCount it had in its role of iPtr->objResultPtr.
- */
+ 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;
- TclNewObj(objPtr);
- Tcl_IncrRefCount(objPtr);
- iPtr->objResultPtr = objPtr;
- NEXT_INST_F(1, 1, -1);
- } else {
- cleanup = 1;
- goto processExceptionReturn;
+ 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);
}
- }
-
- case INST_EXPR_STK: {
- Tcl_Obj *objPtr, *valuePtr;
-
- objPtr = OBJ_AT_TOS;
- DECACHE_STACK_INFO();
- /*Tcl_ResetResult(interp);*/
- result = Tcl_ExprObj(interp, objPtr, &valuePtr);
- CACHE_STACK_INFO();
- if (result == TCL_OK) {
- objResultPtr = valuePtr;
- TRACE_WITH_OBJ(("\"%.30s\" => ", O2S(objPtr)), valuePtr);
- NEXT_INST_F(1, 1, -1); /* Already has right refct. */
- } else {
- TRACE_WITH_OBJ(("\"%.30s\" => ERROR: ", O2S(objPtr)),
- Tcl_GetObjResult(interp));
- goto checkForCatch;
+#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) {
+ int cmd;
+ if (GetSrcInfoForPc(pc, codePtr, NULL, NULL, &cmd)) {
+ TclArgumentBCEnter((Tcl_Interp *) iPtr, objv, objc,
+ codePtr, bcFramePtr, cmd, pc - codePtr->codeStart);
+ }
}
- }
+ 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 some
* common execution code.
*/
- {
- int opnd, pcAdjustment;
- Tcl_Obj *part1Ptr, *part2Ptr;
- Var *varPtr, *arrayPtr;
- Tcl_Obj *objPtr;
case INST_LOAD_SCALAR1:
instLoadScalar1:
opnd = TclGetUInt1AtPtr(pc+1);
- varPtr = &(compiledLocals[opnd]);
+ varPtr = LOCAL(opnd);
while (TclIsVarLink(varPtr)) {
varPtr = varPtr->value.linkPtr;
}
@@ -2665,7 +3093,7 @@ TclExecuteByteCode(
case INST_LOAD_SCALAR4:
opnd = TclGetUInt4AtPtr(pc+1);
- varPtr = &(compiledLocals[opnd]);
+ varPtr = LOCAL(opnd);
while (TclIsVarLink(varPtr)) {
varPtr = varPtr->value.linkPtr;
}
@@ -2697,7 +3125,7 @@ TclExecuteByteCode(
doLoadArray:
part1Ptr = NULL;
part2Ptr = OBJ_AT_TOS;
- arrayPtr = &(compiledLocals[opnd]);
+ arrayPtr = LOCAL(opnd);
while (TclIsVarLink(arrayPtr)) {
arrayPtr = arrayPtr->value.linkPtr;
}
@@ -2717,10 +3145,8 @@ TclExecuteByteCode(
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_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));
+ goto gotError;
}
cleanup = 1;
goto doCallPtrGetVar;
@@ -2744,24 +3170,22 @@ TclExecuteByteCode(
varPtr = TclObjLookupVarEx(interp, part1Ptr, part2Ptr,
TCL_LEAVE_ERR_MSG, "read", /*createPart1*/0, /*createPart2*/1,
&arrayPtr);
- if (varPtr) {
- if (TclIsVarDirectReadable2(varPtr, arrayPtr)) {
- /*
- * No errors, no traces: just get the value.
- */
-
- objResultPtr = varPtr->value.objPtr;
- TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
- NEXT_INST_V(1, cleanup, 1);
- }
- pcAdjustment = 1;
- opnd = -1;
- goto doCallPtrGetVar;
- } else {
+ if (!varPtr) {
TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));
- result = TCL_ERROR;
- goto checkForCatch;
+ goto gotError;
+ }
+
+ if (TclIsVarDirectReadable2(varPtr, arrayPtr)) {
+ /*
+ * No errors, no traces: just get the value.
+ */
+
+ objResultPtr = varPtr->value.objPtr;
+ TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
+ NEXT_INST_V(1, cleanup, 1);
}
+ pcAdjustment = 1;
+ opnd = -1;
doCallPtrGetVar:
/*
@@ -2773,23 +3197,16 @@ TclExecuteByteCode(
objResultPtr = TclPtrGetVar(interp, varPtr, arrayPtr,
part1Ptr, part2Ptr, TCL_LEAVE_ERR_MSG, opnd);
CACHE_STACK_INFO();
- if (objResultPtr) {
- TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
- NEXT_INST_V(pcAdjustment, cleanup, 1);
- } else {
+ if (!objResultPtr) {
TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));
- result = TCL_ERROR;
- goto checkForCatch;
+ 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
@@ -2798,10 +3215,7 @@ TclExecuteByteCode(
*/
{
- int opnd, pcAdjustment, storeFlags;
- Tcl_Obj *part1Ptr, *part2Ptr;
- Var *varPtr, *arrayPtr;
- Tcl_Obj *objPtr, *valuePtr;
+ int storeFlags;
case INST_STORE_ARRAY4:
opnd = TclGetUInt4AtPtr(pc+1);
@@ -2815,7 +3229,7 @@ TclExecuteByteCode(
doStoreArrayDirect:
valuePtr = OBJ_AT_TOS;
part2Ptr = OBJ_UNDER_TOS;
- arrayPtr = &(compiledLocals[opnd]);
+ arrayPtr = LOCAL(opnd);
TRACE(("%u \"%.30s\" <- \"%.30s\" => ", opnd, O2S(part2Ptr),
O2S(valuePtr)));
while (TclIsVarLink(arrayPtr)) {
@@ -2846,39 +3260,40 @@ TclExecuteByteCode(
doStoreScalarDirect:
valuePtr = OBJ_AT_TOS;
- varPtr = &(compiledLocals[opnd]);
+ varPtr = LOCAL(opnd);
TRACE(("%u <- \"%.30s\" => ", opnd, O2S(valuePtr)));
while (TclIsVarLink(varPtr)) {
varPtr = varPtr->value.linkPtr;
}
- if (TclIsVarDirectWritable(varPtr)) {
- doStoreVarDirect:
- /*
- * No traces, no errors, plain 'set': we can safely inline. The
- * value *will* be set to what's requested, so that the stack top
- * remains pointing to the same Tcl_Obj.
- */
+ if (!TclIsVarDirectWritable(varPtr)) {
+ storeFlags = TCL_LEAVE_ERR_MSG;
+ part1Ptr = NULL;
+ goto doStoreScalar;
+ }
- valuePtr = varPtr->value.objPtr;
- if (valuePtr != NULL) {
- TclDecrRefCount(valuePtr);
- }
- objResultPtr = OBJ_AT_TOS;
- varPtr->value.objPtr = objResultPtr;
+ /*
+ * No traces, no errors, plain 'set': we can safely inline. The value
+ * *will* be set to what's requested, so that the stack top remains
+ * pointing to the same Tcl_Obj.
+ */
+
+ 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);
- }
+ if (*(pc+pcAdjustment) == INST_POP) {
+ tosPtr--;
+ NEXT_INST_F((pcAdjustment+1), 0, 0);
+ }
#else
- TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
+ TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
#endif
- Tcl_IncrRefCount(objResultPtr);
- NEXT_INST_F(pcAdjustment, 0, 0);
- }
- storeFlags = TCL_LEAVE_ERR_MSG;
- part1Ptr = NULL;
- goto doStoreScalar;
+ Tcl_IncrRefCount(objResultPtr);
+ NEXT_INST_F(pcAdjustment, 0, 0);
case INST_LAPPEND_STK:
valuePtr = OBJ_AT_TOS; /* value to append */
@@ -2931,16 +3346,14 @@ TclExecuteByteCode(
#endif
varPtr = TclObjLookupVarEx(interp, objPtr,part2Ptr, TCL_LEAVE_ERR_MSG,
"set", /*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr);
- if (varPtr) {
- cleanup = ((part2Ptr == NULL)? 2 : 3);
- pcAdjustment = 1;
- opnd = -1;
- goto doCallPtrSetVar;
- } else {
+ if (!varPtr) {
TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));
- result = TCL_ERROR;
- goto checkForCatch;
+ goto gotError;
}
+ cleanup = ((part2Ptr == NULL)? 2 : 3);
+ pcAdjustment = 1;
+ opnd = -1;
+ goto doCallPtrSetVar;
case INST_LAPPEND_ARRAY4:
opnd = TclGetUInt4AtPtr(pc+1);
@@ -2971,7 +3384,7 @@ TclExecuteByteCode(
doStoreArray:
valuePtr = OBJ_AT_TOS;
part2Ptr = OBJ_UNDER_TOS;
- arrayPtr = &(compiledLocals[opnd]);
+ arrayPtr = LOCAL(opnd);
TRACE(("%u \"%.30s\" <- \"%.30s\" => ", opnd, O2S(part2Ptr),
O2S(valuePtr)));
while (TclIsVarLink(arrayPtr)) {
@@ -2983,13 +3396,11 @@ TclExecuteByteCode(
doStoreArrayDirectFailed:
varPtr = TclLookupArrayElement(interp, part1Ptr, part2Ptr,
TCL_LEAVE_ERR_MSG, "set", 1, 1, arrayPtr, opnd);
- if (varPtr) {
- goto doCallPtrSetVar;
- } else {
+ if (!varPtr) {
TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));
- result = TCL_ERROR;
- goto checkForCatch;
+ goto gotError;
}
+ goto doCallPtrSetVar;
case INST_LAPPEND_SCALAR4:
opnd = TclGetUInt4AtPtr(pc+1);
@@ -3019,7 +3430,7 @@ TclExecuteByteCode(
doStoreScalar:
valuePtr = OBJ_AT_TOS;
- varPtr = &(compiledLocals[opnd]);
+ varPtr = LOCAL(opnd);
TRACE(("%u <- \"%.30s\" => ", opnd, O2S(valuePtr)));
while (TclIsVarLink(varPtr)) {
varPtr = varPtr->value.linkPtr;
@@ -3033,28 +3444,22 @@ TclExecuteByteCode(
objResultPtr = TclPtrSetVar(interp, varPtr, arrayPtr,
part1Ptr, part2Ptr, valuePtr, storeFlags, opnd);
CACHE_STACK_INFO();
- if (objResultPtr) {
-#ifndef TCL_COMPILE_DEBUG
- if (*(pc+pcAdjustment) == INST_POP) {
- NEXT_INST_V((pcAdjustment+1), cleanup, 0);
- }
-#endif
- TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
- NEXT_INST_V(pcAdjustment, cleanup, 1);
- } else {
+ if (!objResultPtr) {
TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));
- result = TCL_ERROR;
- goto checkForCatch;
+ goto gotError;
}
+#ifndef TCL_COMPILE_DEBUG
+ if (*(pc+pcAdjustment) == INST_POP) {
+ NEXT_INST_V((pcAdjustment+1), cleanup, 0);
+ }
+#endif
+ TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
+ NEXT_INST_V(pcAdjustment, cleanup, 1);
}
/*
* End of INST_STORE and related instructions.
- * ---------------------------------------------------------
- */
-
- /*
- * ---------------------------------------------------------
+ * -----------------------------------------------------------------
* Start of INST_INCR instructions.
*
* WARNING: more 'goto' here than your doctor recommended! The different
@@ -3065,14 +3470,11 @@ TclExecuteByteCode(
/*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;
- Tcl_Obj *part1Ptr, *part2Ptr;
- Var *varPtr, *arrayPtr;
+ long increment;
case INST_INCR_SCALAR1:
case INST_INCR_ARRAY1:
@@ -3096,8 +3498,8 @@ 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;
@@ -3107,61 +3509,57 @@ TclExecuteByteCode(
part2Ptr = OBJ_AT_TOS;
objPtr = OBJ_UNDER_TOS;
TRACE(("\"%.30s(%.30s)\" (by %ld) => ",
- O2S(objPtr), O2S(part2Ptr), i));
+ O2S(objPtr), O2S(part2Ptr), increment));
} else {
part2Ptr = NULL;
objPtr = OBJ_AT_TOS;
- TRACE(("\"%.30s\" (by %ld) => ", O2S(objPtr), i));
+ 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) {
- cleanup = ((part2Ptr == NULL)? 1 : 2);
- goto doIncrVar;
- } else {
- Tcl_AddObjErrorInfo(interp,
- "\n (reading value of variable to increment)", -1);
+ if (!varPtr) {
+ Tcl_AddErrorInfo(interp,
+ "\n (reading value of variable to increment)");
TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));
- result = TCL_ERROR;
Tcl_DecrRefCount(incrPtr);
- goto checkForCatch;
+ goto gotError;
}
+ 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:
part1Ptr = NULL;
part2Ptr = OBJ_AT_TOS;
- arrayPtr = &(compiledLocals[opnd]);
+ arrayPtr = LOCAL(opnd);
cleanup = 1;
while (TclIsVarLink(arrayPtr)) {
arrayPtr = arrayPtr->value.linkPtr;
}
- TRACE(("%u \"%.30s\" (by %ld) => ", opnd, O2S(part2Ptr), i));
+ 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) {
- goto doIncrVar;
- } else {
+ if (!varPtr) {
TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));
- result = TCL_ERROR;
Tcl_DecrRefCount(incrPtr);
- goto checkForCatch;
+ goto gotError;
}
+ 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;
}
@@ -3174,16 +3572,16 @@ TclExecuteByteCode(
if (GetNumberFromObj(NULL, objPtr, &ptr, &type) == TCL_OK) {
if (type == TCL_NUMBER_LONG) {
long augend = *((const long *)ptr);
- long sum = augend + i;
+ long sum = augend + increment;
/*
* Overflow when (augend and sum have different sign) and
- * (augend and i have the same sign). This is encapsulated
- * in the Overflowing macro.
+ * (augend and increment have the same sign). This is
+ * encapsulated in the Overflowing macro.
*/
- if (!Overflowing(augend, i, sum)) {
- TRACE(("%u %ld => ", opnd, i));
+ if (!Overflowing(augend, increment, sum)) {
+ TRACE(("%u %ld => ", opnd, increment));
if (Tcl_IsShared(objPtr)) {
objPtr->refCount--; /* We know it's shared. */
TclNewLongObj(objResultPtr, sum);
@@ -3195,43 +3593,41 @@ TclExecuteByteCode(
}
goto doneIncr;
}
-#ifndef NO_WIDE_TYPE
- {
- w = (Tcl_WideInt)augend;
-
- 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;
+#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;
- /*
- * We know the sum value is outside the long
- * range; use macro form that doesn't range test
- * again.
- */
+ /*
+ * 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;
+ 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;
+
+ w = *((const Tcl_WideInt *) ptr);
+ sum = w + increment;
/*
* Check for overflow.
*/
- if (!Overflowing(w, i, sum)) {
- TRACE(("%u %ld => ", opnd, i));
+ if (!Overflowing(w, increment, sum)) {
+ TRACE(("%u %ld => ", opnd, increment));
if (Tcl_IsShared(objPtr)) {
objPtr->refCount--; /* We know it's shared. */
objResultPtr = Tcl_NewWideIntObj(sum);
@@ -3261,34 +3657,33 @@ TclExecuteByteCode(
} else {
objResultPtr = objPtr;
}
- TclNewLongObj(incrPtr, i);
- result = TclIncrObj(interp, objResultPtr, incrPtr);
- Tcl_DecrRefCount(incrPtr);
- if (result == TCL_OK) {
- goto doneIncr;
- } else {
+ TclNewLongObj(incrPtr, increment);
+ if (TclIncrObj(interp, objResultPtr, incrPtr) != TCL_OK) {
+ Tcl_DecrRefCount(incrPtr);
TRACE_APPEND(("ERROR: %.30s\n",
O2S(Tcl_GetObjResult(interp))));
- goto checkForCatch;
+ goto gotError;
}
+ Tcl_DecrRefCount(incrPtr);
+ goto doneIncr;
}
/*
* All other cases, flow through to generic handling.
*/
- TclNewLongObj(incrPtr, i);
+ TclNewLongObj(incrPtr, increment);
Tcl_IncrRefCount(incrPtr);
doIncrScalar:
- varPtr = &(compiledLocals[opnd]);
+ varPtr = LOCAL(opnd);
while (TclIsVarLink(varPtr)) {
varPtr = varPtr->value.linkPtr;
}
arrayPtr = NULL;
part1Ptr = part2Ptr = NULL;
cleanup = 0;
- TRACE(("%u %ld => ", opnd, i));
+ TRACE(("%u %s => ", opnd, Tcl_GetString(incrPtr)));
doIncrVar:
if (TclIsVarDirectModifyable2(varPtr, arrayPtr)) {
@@ -3301,15 +3696,13 @@ TclExecuteByteCode(
} else {
objResultPtr = objPtr;
}
- result = TclIncrObj(interp, objResultPtr, incrPtr);
- Tcl_DecrRefCount(incrPtr);
- if (result == TCL_OK) {
- goto doneIncr;
- } else {
+ if (TclIncrObj(interp, objResultPtr, incrPtr) != TCL_OK) {
+ Tcl_DecrRefCount(incrPtr);
TRACE_APPEND(("ERROR: %.30s\n",
O2S(Tcl_GetObjResult(interp))));
- goto checkForCatch;
+ goto gotError;
}
+ Tcl_DecrRefCount(incrPtr);
} else {
DECACHE_STACK_INFO();
objResultPtr = TclPtrIncrObjVar(interp, varPtr, arrayPtr,
@@ -3319,8 +3712,7 @@ TclExecuteByteCode(
if (objResultPtr == NULL) {
TRACE_APPEND(("ERROR: %.30s\n",
O2S(Tcl_GetObjResult(interp))));
- result = TCL_ERROR;
- goto checkForCatch;
+ goto gotError;
}
}
doneIncr:
@@ -3335,21 +3727,13 @@ TclExecuteByteCode(
/*
* End of INST_INCR instructions.
- * ---------------------------------------------------------
- */
-
- /*
- * ---------------------------------------------------------
+ * -----------------------------------------------------------------
* Start of INST_EXIST instructions.
*/
- {
- Tcl_Obj *part1Ptr, *part2Ptr;
- Var *varPtr, *arrayPtr;
-
- case INST_EXIST_SCALAR: {
- int opnd = TclGetUInt4AtPtr(pc+1);
- varPtr = &(compiledLocals[opnd]);
+ case INST_EXIST_SCALAR:
+ opnd = TclGetUInt4AtPtr(pc+1);
+ varPtr = LOCAL(opnd);
while (TclIsVarLink(varPtr)) {
varPtr = varPtr->value.linkPtr;
}
@@ -3369,16 +3753,14 @@ TclExecuteByteCode(
* Tricky! Arrays always exist.
*/
- objResultPtr = constants[!varPtr || TclIsVarUndefined(varPtr) ? 0 : 1];
+ objResultPtr = TCONST(!varPtr || TclIsVarUndefined(varPtr) ? 0 : 1);
TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
NEXT_INST_F(5, 0, 1);
- }
-
- case INST_EXIST_ARRAY: {
- int opnd = TclGetUInt4AtPtr(pc+1);
+ case INST_EXIST_ARRAY:
+ opnd = TclGetUInt4AtPtr(pc+1);
part2Ptr = OBJ_AT_TOS;
- arrayPtr = &(compiledLocals[opnd]);
+ arrayPtr = LOCAL(opnd);
while (TclIsVarLink(arrayPtr)) {
arrayPtr = arrayPtr->value.linkPtr;
}
@@ -3404,10 +3786,9 @@ TclExecuteByteCode(
}
}
doneExistArray:
- objResultPtr = constants[!varPtr || TclIsVarUndefined(varPtr) ? 0 : 1];
+ objResultPtr = TCONST(!varPtr || TclIsVarUndefined(varPtr) ? 0 : 1);
TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
NEXT_INST_F(5, 1, 1);
- }
case INST_EXIST_ARRAY_STK:
cleanup = 2;
@@ -3437,89 +3818,321 @@ TclExecuteByteCode(
varPtr = NULL;
}
}
- objResultPtr = constants[!varPtr || TclIsVarUndefined(varPtr) ? 0 : 1];
+ objResultPtr = TCONST(!varPtr || TclIsVarUndefined(varPtr) ? 0 : 1);
TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
NEXT_INST_V(1, cleanup, 1);
- }
/*
* End of INST_EXIST instructions.
- * ---------------------------------------------------------
+ * -----------------------------------------------------------------
+ * Start of INST_UNSET instructions.
*/
- case INST_UPVAR: {
- int opnd;
- Var *varPtr, *otherPtr;
+ {
+ int flags;
+
+ case INST_UNSET_SCALAR:
+ flags = TclGetUInt1AtPtr(pc+1) ? TCL_LEAVE_ERR_MSG : 0;
+ opnd = TclGetUInt4AtPtr(pc+2);
+ varPtr = LOCAL(opnd);
+ while (TclIsVarLink(varPtr)) {
+ varPtr = varPtr->value.linkPtr;
+ }
+ TRACE(("%s %u\n", (flags?"normal":"noerr"), opnd));
+ if (TclIsVarDirectUnsettable(varPtr) && !TclIsVarInHash(varPtr)) {
+ /*
+ * No errors, no traces, no searches: just make the variable cease
+ * to exist.
+ */
- TRACE_WITH_OBJ(("upvar "), OBJ_UNDER_TOS);
+ if (!TclIsVarUndefined(varPtr)) {
+ TclDecrRefCount(varPtr->value.objPtr);
+ } else if (flags & TCL_LEAVE_ERR_MSG) {
+ goto slowUnsetScalar;
+ }
+ varPtr->value.objPtr = NULL;
+ NEXT_INST_F(6, 0, 0);
+ }
- {
- CallFrame *framePtr, *savedFramePtr;
+ 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);
- result = TclObjGetFrame(interp, OBJ_UNDER_TOS, &framePtr);
- if (result != -1) {
+ case INST_UNSET_ARRAY:
+ flags = TclGetUInt1AtPtr(pc+1) ? TCL_LEAVE_ERR_MSG : 0;
+ opnd = TclGetUInt4AtPtr(pc+2);
+ part2Ptr = OBJ_AT_TOS;
+ arrayPtr = LOCAL(opnd);
+ while (TclIsVarLink(arrayPtr)) {
+ arrayPtr = arrayPtr->value.linkPtr;
+ }
+ TRACE(("%s %u \"%.30s\"\n",
+ (flags ? "normal" : "noerr"), opnd, O2S(part2Ptr)));
+ if (TclIsVarArray(arrayPtr) && !UnsetTraced(arrayPtr)) {
+ varPtr = VarHashFindVar(arrayPtr->value.tablePtr, part2Ptr);
+ if (varPtr && TclIsVarDirectUnsettable(varPtr)) {
/*
- * Locate the other variable.
+ * No nasty traces and element exists, so we can proceed to
+ * unset it. Might still not exist though...
*/
- savedFramePtr = iPtr->varFramePtr;
- iPtr->varFramePtr = framePtr;
- otherPtr = TclObjLookupVarEx(interp, OBJ_AT_TOS, NULL,
- (TCL_LEAVE_ERR_MSG), "access",
- /*createPart1*/ 1, /*createPart2*/ 1, &varPtr);
- iPtr->varFramePtr = savedFramePtr;
- if (otherPtr) {
- result = TCL_OK;
- goto doLinkVars;
+ if (!TclIsVarUndefined(varPtr)) {
+ TclDecrRefCount(varPtr->value.objPtr);
+ } else if (flags & TCL_LEAVE_ERR_MSG) {
+ goto slowUnsetArray;
}
+ varPtr->value.objPtr = NULL;
+ NEXT_INST_F(6, 1, 0);
+ } else if (!varPtr && !(flags & TCL_LEAVE_ERR_MSG)) {
+ /*
+ * Don't need to do anything here.
+ */
+
+ NEXT_INST_F(6, 1, 0);
}
- result = TCL_ERROR;
- goto checkForCatch;
}
+ slowUnsetArray:
+ DECACHE_STACK_INFO();
+ varPtr = TclLookupArrayElement(interp, NULL, part2Ptr, flags, "unset",
+ 0, 0, arrayPtr, opnd);
+ if (!varPtr) {
+ if (flags & TCL_LEAVE_ERR_MSG) {
+ goto errorInUnset;
+ }
+ } else if (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_VARIABLE:
- TRACE(("variable "));
- otherPtr = TclObjLookupVarEx(interp, OBJ_AT_TOS, NULL,
- (TCL_NAMESPACE_ONLY | TCL_LEAVE_ERR_MSG), "access",
- /*createPart1*/ 1, /*createPart2*/ 1, &varPtr);
- if (otherPtr) {
- /*
- * Do the [variable] magic.
- */
+ case INST_UNSET_ARRAY_STK:
+ flags = TclGetUInt1AtPtr(pc+1) ? TCL_LEAVE_ERR_MSG : 0;
+ cleanup = 2;
+ part2Ptr = OBJ_AT_TOS; /* element name */
+ part1Ptr = OBJ_UNDER_TOS; /* array name */
+ TRACE(("%s \"%.30s(%.30s)\"\n", (flags?"normal":"noerr"),
+ O2S(part1Ptr), O2S(part2Ptr)));
+ goto doUnsetStk;
- TclSetVarNamespaceVar(otherPtr);
- result = TCL_OK;
- goto doLinkVars;
+ case INST_UNSET_STK:
+ flags = TclGetUInt1AtPtr(pc+1) ? TCL_LEAVE_ERR_MSG : 0;
+ cleanup = 1;
+ part2Ptr = NULL;
+ part1Ptr = OBJ_AT_TOS; /* variable name */
+ TRACE(("%s \"%.30s\"\n", (flags?"normal":"noerr"), O2S(part1Ptr)));
+
+ doUnsetStk:
+ DECACHE_STACK_INFO();
+ if (TclObjUnsetVar2(interp, part1Ptr, part2Ptr, flags) != TCL_OK
+ && (flags & TCL_LEAVE_ERR_MSG)) {
+ goto errorInUnset;
}
- result = TCL_ERROR;
- goto checkForCatch;
+ CACHE_STACK_INFO();
+ NEXT_INST_V(2, cleanup, 0);
- case INST_NSUPVAR:
- TRACE_WITH_OBJ(("nsupvar "), OBJ_UNDER_TOS);
+ errorInUnset:
+ CACHE_STACK_INFO();
+ TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));
+ goto gotError;
- {
- Tcl_Namespace *nsPtr, *savedNsPtr;
+ /*
+ * This is really an unset operation these days. Do not issue.
+ */
+
+ case INST_DICT_DONE:
+ opnd = TclGetUInt4AtPtr(pc+1);
+ TRACE(("%u\n", opnd));
+ varPtr = LOCAL(opnd);
+ while (TclIsVarLink(varPtr)) {
+ varPtr = varPtr->value.linkPtr;
+ }
+ if (TclIsVarDirectUnsettable(varPtr) && !TclIsVarInHash(varPtr)) {
+ if (!TclIsVarUndefined(varPtr)) {
+ TclDecrRefCount(varPtr->value.objPtr);
+ }
+ varPtr->value.objPtr = NULL;
+ } else {
+ DECACHE_STACK_INFO();
+ TclPtrUnsetVar(interp, varPtr, NULL, NULL, NULL, 0, opnd);
+ CACHE_STACK_INFO();
+ }
+ NEXT_INST_F(5, 0, 0);
+ }
+
+ /*
+ * End of INST_UNSET instructions.
+ * -----------------------------------------------------------------
+ * Start of 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_APPEND(("ERROR: %.30s\n",
+ O2S(Tcl_GetObjResult(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);
- result = TclGetNamespaceFromObj(interp, OBJ_UNDER_TOS, &nsPtr);
- if (result == TCL_OK) {
+ 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_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));
+ goto gotError;
+ }
+ doArrayMake:
+ if (varPtr && !TclIsVarArray(varPtr)) {
+ if (TclIsVarArrayElement(varPtr) || !TclIsVarUndefined(varPtr)) {
/*
- * Locate the other variable.
+ * Either an array element, or a scalar: lose!
*/
- savedNsPtr = (Tcl_Namespace *) iPtr->varFramePtr->nsPtr;
- iPtr->varFramePtr->nsPtr = (Namespace *) nsPtr;
- otherPtr = TclObjLookupVarEx(interp, OBJ_AT_TOS, NULL,
- (TCL_NAMESPACE_ONLY | TCL_LEAVE_ERR_MSG), "access",
- /*createPart1*/ 1, /*createPart2*/ 1, &varPtr);
- iPtr->varFramePtr->nsPtr = (Namespace *) savedNsPtr;
- if (otherPtr) {
- goto doLinkVars;
- }
+ TclObjVarErrMsg(interp, part1Ptr, NULL, "array set",
+ "variable isn't array", opnd);
+ Tcl_SetErrorCode(interp, "TCL", "WRITE", "ARRAY", NULL);
+ TRACE_APPEND(("ERROR: bad array ref: %.30s\n",
+ O2S(Tcl_GetObjResult(interp))));
+ goto gotError;
}
- result = TCL_ERROR;
- goto checkForCatch;
+ 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_WITH_OBJ(("upvar "), OBJ_UNDER_TOS);
+
+ if (TclObjGetFrame(interp, OBJ_UNDER_TOS, &framePtr) == -1) {
+ goto gotError;
}
+ /*
+ * Locate the other variable.
+ */
+
+ savedFramePtr = iPtr->varFramePtr;
+ iPtr->varFramePtr = framePtr;
+ otherPtr = TclObjLookupVarEx(interp, OBJ_AT_TOS, NULL,
+ TCL_LEAVE_ERR_MSG, "access", /*createPart1*/ 1,
+ /*createPart2*/ 1, &varPtr);
+ iPtr->varFramePtr = savedFramePtr;
+ if (!otherPtr) {
+ goto gotError;
+ }
+ goto doLinkVars;
+
+ case INST_NSUPVAR:
+ TRACE_WITH_OBJ(("nsupvar "), OBJ_UNDER_TOS);
+ if (TclGetNamespaceFromObj(interp, OBJ_UNDER_TOS, &nsPtr) != TCL_OK) {
+ goto gotError;
+ }
+
+ /*
+ * Locate the other variable.
+ */
+
+ savedNsPtr = iPtr->varFramePtr->nsPtr;
+ iPtr->varFramePtr->nsPtr = (Namespace *) nsPtr;
+ otherPtr = TclObjLookupVarEx(interp, OBJ_AT_TOS, NULL,
+ (TCL_NAMESPACE_ONLY | TCL_LEAVE_ERR_MSG), "access",
+ /*createPart1*/ 1, /*createPart2*/ 1, &varPtr);
+ iPtr->varFramePtr->nsPtr = savedNsPtr;
+ if (!otherPtr) {
+ goto gotError;
+ }
+ goto doLinkVars;
+
+ case INST_VARIABLE:
+ TRACE(("variable "));
+ otherPtr = TclObjLookupVarEx(interp, OBJ_AT_TOS, NULL,
+ (TCL_NAMESPACE_ONLY | TCL_LEAVE_ERR_MSG), "access",
+ /*createPart1*/ 1, /*createPart2*/ 1, &varPtr);
+ if (!otherPtr) {
+ goto gotError;
+ }
+
+ /*
+ * Do the [variable] magic.
+ */
+
+ TclSetVarNamespaceVar(otherPtr);
+
doLinkVars:
/*
@@ -3529,7 +4142,7 @@ TclExecuteByteCode(
*/
opnd = TclGetInt4AtPtr(pc+1);;
- varPtr = &(compiledLocals[opnd]);
+ varPtr = LOCAL(opnd);
if ((varPtr != otherPtr) && !TclIsVarTraced(varPtr)
&& (TclIsVarUndefined(varPtr) || TclIsVarLink(varPtr))) {
if (!TclIsVarUndefined(varPtr)) {
@@ -3540,7 +4153,7 @@ TclExecuteByteCode(
Var *linkPtr = varPtr->value.linkPtr;
if (linkPtr == otherPtr) {
- goto doLinkVarsDone;
+ NEXT_INST_F(5, 1, 0);
}
if (TclIsVarInHash(linkPtr)) {
VarHashRefCount(linkPtr)--;
@@ -3554,11 +4167,9 @@ TclExecuteByteCode(
if (TclIsVarInHash(otherPtr)) {
VarHashRefCount(otherPtr)++;
}
- } else {
- result = TclPtrObjMakeUpvar(interp, otherPtr, NULL, 0, opnd);
- if (result != TCL_OK) {
- goto checkForCatch;
- }
+ } else if (TclPtrObjMakeUpvar(interp, otherPtr, NULL, 0,
+ opnd) != TCL_OK) {
+ goto gotError;
}
/*
@@ -3566,35 +4177,34 @@ TclExecuteByteCode(
* variables - and [variable] did not push it at all.
*/
- doLinkVarsDone:
NEXT_INST_F(5, 1, 0);
}
- case INST_JUMP1: {
- int opnd = TclGetInt1AtPtr(pc+1);
+ /*
+ * End of variable linking instructions.
+ * -----------------------------------------------------------------
+ */
+ case INST_JUMP1:
+ opnd = TclGetInt1AtPtr(pc+1);
TRACE(("%d => new pc %u\n", opnd,
(unsigned)(pc + opnd - codePtr->codeStart)));
NEXT_INST_F(opnd, 0, 0);
- }
-
- case INST_JUMP4: {
- int opnd = TclGetInt4AtPtr(pc+1);
+ case INST_JUMP4:
+ opnd = TclGetInt4AtPtr(pc+1);
TRACE(("%d => new pc %u\n", opnd,
(unsigned)(pc + opnd - codePtr->codeStart)));
NEXT_INST_F(opnd, 0, 0);
- }
{
int jmpOffset[2], b;
- Tcl_Obj *valuePtr;
/* TODO: consider rewrite so we don't compute the offset we're not
* going to take. */
case INST_JUMP_FALSE4:
jmpOffset[0] = TclGetInt4AtPtr(pc+1); /* FALSE offset */
- jmpOffset[1] = 5; /* TRUE offset*/
+ jmpOffset[1] = 5; /* TRUE offset */
goto doCondJump;
case INST_JUMP_TRUE4:
@@ -3616,12 +4226,11 @@ TclExecuteByteCode(
/* TODO - check claim that taking address of b harms performance */
/* TODO - consider optimization search for constants */
- result = TclGetBooleanFromObj(interp, valuePtr, &b);
- if (result != TCL_OK) {
+ if (TclGetBooleanFromObj(interp, valuePtr, &b) != TCL_OK) {
TRACE_WITH_OBJ(("%d => ERROR: ", jmpOffset[
((*pc == INST_JUMP_FALSE1) || (*pc == INST_JUMP_FALSE4))
? 0 : 1]), Tcl_GetObjResult(interp));
- goto checkForCatch;
+ goto gotError;
}
#ifdef TCL_COMPILE_DEBUG
@@ -3639,7 +4248,7 @@ TclExecuteByteCode(
} else {
TRACE(("%d => %.20s false, new pc %u\n", jmpOffset[0],
O2S(valuePtr),
- (unsigned)(pc + jmpOffset[1] - codePtr->codeStart)));
+ (unsigned)(pc + jmpOffset[0] - codePtr->codeStart)));
}
}
#endif
@@ -3649,7 +4258,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
@@ -3685,27 +4293,25 @@ TclExecuteByteCode(
*/
int i1, i2, iResult;
- Tcl_Obj *value2Ptr = OBJ_AT_TOS;
- Tcl_Obj *valuePtr = OBJ_UNDER_TOS;
- 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);
CACHE_STACK_INFO();
- goto checkForCatch;
+ 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);
CACHE_STACK_INFO();
- goto checkForCatch;
+ goto gotError;
}
if (*pc == INST_LOR) {
@@ -3713,61 +4319,174 @@ TclExecuteByteCode(
} else {
iResult = (i1 && i2);
}
- objResultPtr = constants[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_LIST: {
- /*
- * Pop the opnd (objc) top stack elements into a new list obj and then
- * decrement their ref counts.
- */
+ case INST_NS_CURRENT: {
+ Namespace *currNsPtr = (Namespace *) TclGetCurrentNamespace(interp);
- int opnd;
-
- 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);
+ 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;
- case INST_LIST_LENGTH: {
- Tcl_Obj *valuePtr;
- int length;
+ 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;
valuePtr = OBJ_AT_TOS;
-
- result = TclListObjLength(interp, valuePtr, &length);
- if (result == TCL_OK) {
- TclNewIntObj(objResultPtr, length);
- TRACE(("%.20s => %d\n", O2S(valuePtr), length));
- NEXT_INST_F(1, 1, 1);
- } else {
+ if (TclGetIntFromObj(interp, valuePtr, &level) != TCL_OK) {
TRACE_WITH_OBJ(("%.30s => ERROR: ", O2S(valuePtr)),
Tcl_GetObjResult(interp));
- goto checkForCatch;
+ goto gotError;
+ }
+ TRACE(("%d => ", level));
+ if (level <= 0) {
+ level += framePtr->level;
+ }
+ for (; (framePtr->level!=level) && (framePtr!=rootFramePtr) ;
+ framePtr = framePtr->callerVarPtr) {
+ /* Empty loop body */
}
+ if (framePtr == rootFramePtr) {
+ Tcl_AppendResult(interp, "bad level \"", TclGetString(valuePtr),
+ "\"", NULL);
+ TRACE_APPEND(("ERROR: bad level\n"));
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "STACK_LEVEL",
+ TclGetString(valuePtr), NULL);
+ goto gotError;
+ }
+ objResultPtr = Tcl_NewListObj(framePtr->objc, framePtr->objv);
+ TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
+ NEXT_INST_F(1, 1, 1);
}
+ case INST_RESOLVE_COMMAND: {
+ Tcl_Command cmd = Tcl_GetCommandFromObj(interp, OBJ_AT_TOS);
- case INST_LIST_INDEX: {
- /*** lindex with objc == 3 ***/
+ 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_TCLOO_SELF: {
+ CallFrame *framePtr = iPtr->varFramePtr;
+ CallContext *contextPtr;
- /* Variables also for INST_LIST_INDEX_IMM */
+ 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));
+ Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", NULL);
+ goto gotError;
+ }
+ contextPtr = framePtr->clientData;
+
+ /*
+ * Call out to get the name; it's expensive to compute but cached.
+ */
+
+ objResultPtr = TclOOObjectName(interp, contextPtr->oPtr);
+ TRACE_WITH_OBJ(("=> "), objResultPtr);
+ NEXT_INST_F(1, 0, 1);
+ }
+ {
+ Object *oPtr;
+
+ 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);
+ }
+
+ /*
+ * -----------------------------------------------------------------
+ * Start of INST_LIST and related instructions.
+ */
- int listc, idx, opnd, pcAdjustment;
- Tcl_Obj **listv;
- 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.
*/
+ 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:
+ valuePtr = OBJ_AT_TOS;
+ if (TclListObjLength(interp, valuePtr, &length) != TCL_OK) {
+ TRACE_WITH_OBJ(("%.30s => ERROR: ", O2S(valuePtr)),
+ Tcl_GetObjResult(interp));
+ goto gotError;
+ }
+ TclNewIntObj(objResultPtr, length);
+ TRACE(("%.20s => %d\n", O2S(valuePtr), length));
+ NEXT_INST_F(1, 1, 1);
+
+ case INST_LIST_INDEX: /* lindex with objc == 3 */
value2Ptr = OBJ_AT_TOS;
valuePtr = OBJ_UNDER_TOS;
@@ -3775,10 +4494,10 @@ TclExecuteByteCode(
* Extract the desired list element.
*/
- result = TclListObjGetElements(interp, valuePtr, &listc, &listv);
- if ((result == TCL_OK) && (value2Ptr->typePtr != &tclListType)
- && (TclGetIntForIndexM(NULL , value2Ptr, listc-1,
- &idx) == TCL_OK)) {
+ if ((TclListObjGetElements(interp, valuePtr, &objc, &objv) == TCL_OK)
+ && (value2Ptr->typePtr != &tclListType)
+ && (TclGetIntForIndexM(NULL , value2Ptr, objc-1,
+ &index) == TCL_OK)) {
TclDecrRefCount(value2Ptr);
tosPtr--;
pcAdjustment = 1;
@@ -3786,25 +4505,22 @@ TclExecuteByteCode(
}
objResultPtr = TclLindexList(interp, valuePtr, value2Ptr);
- if (objResultPtr) {
- /*
- * 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 */
- } else {
+ if (!objResultPtr) {
TRACE_WITH_OBJ(("%.30s %.30s => ERROR: ", O2S(valuePtr),
O2S(value2Ptr)), Tcl_GetObjResult(interp));
- result = TCL_ERROR;
- goto checkForCatch;
+ goto gotError;
}
- case INST_LIST_INDEX_IMM:
- /*** lindex with objc==3 and index in bytecode stream ***/
+ /*
+ * Stash the list element on the stack.
+ */
- pcAdjustment = 5;
+ 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 */
/*
* Pop the list and get the index.
@@ -3818,84 +4534,68 @@ TclExecuteByteCode(
* in the process.
*/
- result = TclListObjGetElements(interp, valuePtr, &listc, &listv);
-
- if (result == TCL_OK) {
- /*
- * Select the list item based on the index. Negative operand means
- * end-based indexing.
- */
+ if (TclListObjGetElements(interp, valuePtr, &objc, &objv) != TCL_OK) {
+ TRACE_WITH_OBJ(("\"%.30s\" %d => ERROR: ", O2S(valuePtr), opnd),
+ Tcl_GetObjResult(interp));
+ goto gotError;
+ }
- if (opnd < -1) {
- idx = opnd+1 + listc;
- } else {
- idx = opnd;
- }
+ /*
+ * Select the list item based on the index. Negative operand means
+ * end-based indexing.
+ */
- lindexFastPath:
- if (idx >= 0 && idx < listc) {
- objResultPtr = listv[idx];
- } else {
- TclNewObj(objResultPtr);
- }
+ if (opnd < -1) {
+ index = opnd+1 + objc;
+ } else {
+ index = opnd;
+ }
+ pcAdjustment = 5;
- TRACE_WITH_OBJ(("\"%.30s\" %d => ", O2S(valuePtr), opnd),
- objResultPtr);
- NEXT_INST_F(pcAdjustment, 1, 1);
+ lindexFastPath:
+ if (index >= 0 && index < objc) {
+ objResultPtr = objv[index];
} else {
- TRACE_WITH_OBJ(("\"%.30s\" %d => ERROR: ", O2S(valuePtr), opnd),
- Tcl_GetObjResult(interp));
- goto checkForCatch;
+ TclNewObj(objResultPtr);
}
- }
- case INST_LIST_INDEX_MULTI: {
+ TRACE_WITH_OBJ(("\"%.30s\" %d => ", O2S(valuePtr), opnd),
+ objResultPtr);
+ NEXT_INST_F(pcAdjustment, 1, 1);
+
+ case INST_LIST_INDEX_MULTI: /* 'lindex' with multiple index args */
/*
- * '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, OBJ_AT_DEPTH(numIdx),
- numIdx, &OBJ_AT_DEPTH(numIdx - 1));
+ objResultPtr = TclLindexFlat(interp, OBJ_AT_DEPTH(numIndices),
+ numIndices, &OBJ_AT_DEPTH(numIndices - 1));
+ if (!objResultPtr) {
+ TRACE_WITH_OBJ(("%d => ERROR: ", opnd), Tcl_GetObjResult(interp));
+ goto gotError;
+ }
/*
- * Check for errors.
+ * Set result.
*/
- if (objResultPtr) {
- /*
- * Set result.
- */
-
- TRACE(("%d => %s\n", opnd, O2S(objResultPtr)));
- NEXT_INST_V(5, opnd, -1);
- } else {
- TRACE_WITH_OBJ(("%d => ERROR: ", opnd), Tcl_GetObjResult(interp));
- result = TCL_ERROR;
- goto checkForCatch;
- }
- }
+ TRACE(("%d => %s\n", opnd, 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.
*/
- int numIdx,opnd;
- Tcl_Obj *valuePtr, *value2Ptr;
-
opnd = TclGetUInt4AtPtr(pc + 1);
- numIdx = opnd - 2;
+ numIndices = opnd - 2;
/*
* Get the old value of variable, and remove the stack ref. This is
@@ -3904,47 +4604,28 @@ TclExecuteByteCode(
* Tcl_DecrRefCount.
*/
- value2Ptr = POP_OBJECT();
- Tcl_DecrRefCount(value2Ptr); /* This one should be done here */
-
- /*
- * Get the new element value.
- */
-
- valuePtr = OBJ_AT_TOS;
+ valuePtr = POP_OBJECT();
+ Tcl_DecrRefCount(valuePtr); /* This one should be done here */
/*
* Compute the new variable value.
*/
- objResultPtr = TclLsetFlat(interp, value2Ptr, numIdx,
- &OBJ_AT_DEPTH(numIdx), valuePtr);
-
- /*
- * Check for errors.
- */
-
- if (objResultPtr) {
- /*
- * Set result.
- */
-
- TRACE(("%d => %s\n", opnd, O2S(objResultPtr)));
- NEXT_INST_V(5, (numIdx+1), -1);
- } else {
+ objResultPtr = TclLsetFlat(interp, valuePtr, numIndices,
+ &OBJ_AT_DEPTH(numIndices), OBJ_AT_TOS);
+ if (!objResultPtr) {
TRACE_WITH_OBJ(("%d => ERROR: ", opnd), Tcl_GetObjResult(interp));
- result = TCL_ERROR;
- goto checkForCatch;
+ goto gotError;
}
- }
- case INST_LSET_LIST: {
/*
- * 'lset' with 4 args.
+ * Set result.
*/
- Tcl_Obj *objPtr, *valuePtr, *value2Ptr;
+ TRACE(("%d => %s\n", opnd, O2S(objResultPtr)));
+ NEXT_INST_V(5, numIndices+1, -1);
+ case INST_LSET_LIST: /* 'lset' with 4 args */
/*
* Get the old value of variable, and remove the stack ref. This is
* safe because the variable still references the object; the ref
@@ -3967,31 +4648,21 @@ TclExecuteByteCode(
*/
objResultPtr = TclLsetList(interp, objPtr, value2Ptr, valuePtr);
-
- /*
- * Check for errors.
- */
-
- if (objResultPtr) {
- /*
- * Set result.
- */
-
- TRACE(("=> %s\n", O2S(objResultPtr)));
- NEXT_INST_F(1, 2, -1);
- } else {
+ if (!objResultPtr) {
TRACE_WITH_OBJ(("\"%.30s\" => ERROR: ", O2S(value2Ptr)),
Tcl_GetObjResult(interp));
- result = TCL_ERROR;
- goto checkForCatch;
+ goto gotError;
}
- }
- case INST_LIST_RANGE_IMM: {
- /*** lrange with objc==4 and both indices in bytecode stream ***/
+ /*
+ * Set result.
+ */
+
+ TRACE(("=> %s\n", O2S(objResultPtr)));
+ NEXT_INST_F(1, 2, -1);
- int listc, fromIdx, toIdx;
- Tcl_Obj **listv, *valuePtr;
+ case INST_LIST_RANGE_IMM: /* lrange with objc==4 and both indices in
+ * bytecode stream */
/*
* Pop the list and get the indices.
@@ -4005,44 +4676,43 @@ TclExecuteByteCode(
* Get the contents of the list, making sure that it really is a list
* in the process.
*/
- result = TclListObjGetElements(interp, valuePtr, &listc, &listv);
+
+ if (TclListObjGetElements(interp, valuePtr, &objc, &objv) != TCL_OK) {
+ TRACE_WITH_OBJ(("\"%.30s\" %d %d => ERROR: ", O2S(valuePtr),
+ fromIdx, toIdx), Tcl_GetObjResult(interp));
+ goto gotError;
+ }
/*
* Skip a lot of work if we're about to throw the result away (common
* with uses of [lassign]).
*/
- if (result == TCL_OK) {
#ifndef TCL_COMPILE_DEBUG
- if (*(pc+9) == INST_POP) {
- NEXT_INST_F(10, 1, 0);
- }
-#endif
- } else {
- TRACE_WITH_OBJ(("\"%.30s\" %d %d => ERROR: ", O2S(valuePtr),
- fromIdx, toIdx), Tcl_GetObjResult(interp));
- goto checkForCatch;
+ if (*(pc+9) == INST_POP) {
+ NEXT_INST_F(10, 1, 0);
}
+#endif
/*
* 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;
}
/*
@@ -4050,14 +4720,35 @@ TclExecuteByteCode(
* 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) {
+ TRACE(("\"%.30s\" %d %d => ", O2S(valuePtr),
+ TclGetInt4AtPtr(pc+1), TclGetInt4AtPtr(pc+5)));
+ 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);
}
@@ -4065,56 +4756,47 @@ TclExecuteByteCode(
TRACE_WITH_OBJ(("\"%.30s\" %d %d => ", O2S(valuePtr),
TclGetInt4AtPtr(pc+1), TclGetInt4AtPtr(pc+5)), objResultPtr);
NEXT_INST_F(9, 1, 1);
- }
case INST_LIST_IN:
- case INST_LIST_NOT_IN: {
- /*
- * Basic list containment operators.
- */
-
- int found, s1len, s2len, llen, i;
- Tcl_Obj *valuePtr, *value2Ptr, *o;
- char *s1;
- const char *s2;
-
+ case INST_LIST_NOT_IN: /* Basic list containment operators. */
value2Ptr = OBJ_AT_TOS;
valuePtr = OBJ_UNDER_TOS;
- /* TODO: Consider more efficient tests than strcmp() */
s1 = TclGetStringFromObj(valuePtr, &s1len);
- result = TclListObjLength(interp, value2Ptr, &llen);
- if (result != TCL_OK) {
+ if (TclListObjLength(interp, value2Ptr, &length) != TCL_OK) {
TRACE_WITH_OBJ(("\"%.30s\" \"%.30s\" => ERROR: ", O2S(valuePtr),
O2S(value2Ptr)), Tcl_GetObjResult(interp));
- goto checkForCatch;
+ goto gotError;
}
- found = 0;
- if (llen > 0) {
+ match = 0;
+ if (length > 0) {
+ int i = 0;
+ Tcl_Obj *o;
+
/*
* An empty list doesn't match anything.
*/
- i = 0;
do {
Tcl_ListObjIndex(NULL, value2Ptr, i, &o);
if (o != NULL) {
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(("%.20s %.20s => %d\n", O2S(valuePtr), O2S(value2Ptr), match));
/*
* Peep-hole optimisation: if you're about to jump, do jump from here.
@@ -4126,150 +4808,134 @@ TclExecuteByteCode(
#ifndef TCL_COMPILE_DEBUG
switch (*pc) {
case INST_JUMP_FALSE1:
- NEXT_INST_F((found ? 2 : TclGetInt1AtPtr(pc+1)), 2, 0);
+ NEXT_INST_F((match ? 2 : TclGetInt1AtPtr(pc+1)), 2, 0);
case INST_JUMP_TRUE1:
- NEXT_INST_F((found ? TclGetInt1AtPtr(pc+1) : 2), 2, 0);
+ NEXT_INST_F((match ? TclGetInt1AtPtr(pc+1) : 2), 2, 0);
case INST_JUMP_FALSE4:
- NEXT_INST_F((found ? 5 : TclGetInt4AtPtr(pc+1)), 2, 0);
+ NEXT_INST_F((match ? 5 : TclGetInt4AtPtr(pc+1)), 2, 0);
case INST_JUMP_TRUE4:
- NEXT_INST_F((found ? TclGetInt4AtPtr(pc+1) : 5), 2, 0);
+ NEXT_INST_F((match ? TclGetInt4AtPtr(pc+1) : 5), 2, 0);
}
#endif
- objResultPtr = constants[found];
+ objResultPtr = TCONST(match);
NEXT_INST_F(0, 2, 1);
- }
+
+ 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_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(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_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));
+ goto gotError;
+ }
+ TRACE_APPEND(("\"%.30s\"\n", O2S(valuePtr)));
+ NEXT_INST_F(1, 1, 0);
+ }
/*
* 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;
-
+ 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 = TclGetStringFromObj(valuePtr, &s1len);
- s2 = TclGetStringFromObj(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 = 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 = OBJ_AT_TOS;
- valuePtr = OBJ_UNDER_TOS;
-
- /*
- * 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 = TclGetStringFromObj(valuePtr, &s1len);
- s2 = TclGetStringFromObj(value2Ptr, &s2len);
- iResult = TclpUtfNcmp2(s1, s2,
- (size_t) ((s1len < s2len) ? s1len : s2len));
}
/*
@@ -4277,133 +4943,260 @@ TclExecuteByteCode(
* TODO: consider peephole opt.
*/
- if (iResult == 0) {
- iResult = s1len - s2len;
- }
-
if (*pc != INST_STR_CMP) {
/*
* Take care of the opcodes that goto'ed into here.
*/
switch (*pc) {
+ case INST_STR_EQ:
case INST_EQ:
- 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) {
+ if (match < 0) {
TclNewIntObj(objResultPtr, -1);
- TRACE(("%.20s %.20s => %d\n", O2S(valuePtr), O2S(value2Ptr), -1));
} else {
- objResultPtr = constants[(iResult>0)];
- TRACE(("%.20s %.20s => %d\n", O2S(valuePtr), O2S(value2Ptr),
- (iResult > 0)));
+ objResultPtr = TCONST(match > 0);
}
-
+ TRACE(("%.20s %.20s => %s\n", O2S(valuePtr), O2S(value2Ptr),
+ O2S(objResultPtr)));
NEXT_INST_F(1, 2, 1);
- }
-
- case INST_STR_LEN: {
- int length;
- Tcl_Obj *valuePtr;
+ case INST_STR_LEN:
valuePtr = OBJ_AT_TOS;
-
- if (valuePtr->typePtr == &tclByteArrayType) {
- (void) Tcl_GetByteArrayFromObj(valuePtr, &length);
- } else {
- length = Tcl_GetCharLength(valuePtr);
- }
+ length = Tcl_GetCharLength(valuePtr);
TclNewIntObj(objResultPtr, length);
TRACE(("%.20s => %d\n", O2S(valuePtr), length));
NEXT_INST_F(1, 1, 1);
- }
- case INST_STR_INDEX: {
- /*
- * String compare.
- */
-
- int index, length;
- char *bytes;
- Tcl_Obj *valuePtr, *value2Ptr;
-
- bytes = NULL; /* lint */
+ case INST_STR_INDEX:
value2Ptr = OBJ_AT_TOS;
valuePtr = OBJ_UNDER_TOS;
/*
- * 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.
+ * Get char length to calulate what 'end' means.
*/
- if (valuePtr->typePtr == &tclByteArrayType) {
- bytes = (char *)Tcl_GetByteArrayFromObj(valuePtr, &length);
+ length = Tcl_GetCharLength(valuePtr);
+ if (TclGetIntForIndexM(interp, value2Ptr, length-1, &index)!=TCL_OK) {
+ 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 {
+ char buf[TCL_UTF_MAX];
+ Tcl_UniChar ch = Tcl_GetUniChar(valuePtr, index);
+
/*
- * Get Unicode char length to calulate what 'end' means.
+ * 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_GetCharLength(valuePtr);
+ length = Tcl_UniCharToUtf(ch, buf);
+ objResultPtr = Tcl_NewStringObj(buf, length);
}
- result = TclGetIntForIndexM(interp, value2Ptr, length - 1, &index);
- if (result != TCL_OK) {
- goto checkForCatch;
+ TRACE(("%.20s %.20s => %s\n", O2S(valuePtr), O2S(value2Ptr),
+ O2S(objResultPtr)));
+ NEXT_INST_F(1, 2, 1);
+
+ case INST_STR_RANGE:
+ TRACE(("\"%.20s\" %s %s =>",
+ 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) {
+ goto gotError;
}
- if ((index >= 0) && (index < length)) {
- if (valuePtr->typePtr == &tclByteArrayType) {
- objResultPtr = Tcl_NewByteArrayObj((unsigned char *)
- (&bytes[index]), 1);
- } else if (valuePtr->bytes && length == valuePtr->length) {
- objResultPtr = Tcl_NewStringObj((const char *)
- (&valuePtr->bytes[index]), 1);
- } else {
- char buf[TCL_UTF_MAX];
- Tcl_UniChar ch;
+ 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);
- ch = Tcl_GetUniChar(valuePtr, index);
+ 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));
- /*
- * This could be: Tcl_NewUnicodeObj((const Tcl_UniChar *)&ch,
- * 1) but creating the object as a string seems to be faster
- * in practical use.
- */
+ /*
+ * Adjust indices for end-based indexing.
+ */
- length = Tcl_UniCharToUtf(ch, buf);
- objResultPtr = Tcl_NewStringObj(buf, 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 {
TclNewObj(objResultPtr);
}
+ TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
+ NEXT_INST_F(9, 1, 1);
- TRACE(("%.20s %.20s => %s\n", O2S(valuePtr), O2S(value2Ptr),
- O2S(objResultPtr)));
+ {
+ Tcl_UniChar *ustring1, *ustring2, *ustring3, *end, *p;
+ int length3;
+ Tcl_Obj *value3Ptr;
+
+ 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;
+ NEXT_INST_V(1, 3, 1);
+ } else if (valuePtr == value2Ptr) {
+ objResultPtr = value3Ptr;
+ NEXT_INST_V(1, 3, 1);
+ }
+ ustring1 = Tcl_GetUnicodeFromObj(valuePtr, &length);
+ if (length == 0) {
+ objResultPtr = valuePtr;
+ NEXT_INST_V(1, 3, 1);
+ }
+ ustring2 = Tcl_GetUnicodeFromObj(value2Ptr, &length2);
+ if (length2 > length || length2 == 0) {
+ objResultPtr = valuePtr;
+ NEXT_INST_V(1, 3, 1);
+ } else if (length2 == length) {
+ if (memcmp(ustring1, ustring2, sizeof(Tcl_UniChar) * length)) {
+ objResultPtr = valuePtr;
+ } else {
+ objResultPtr = value3Ptr;
+ }
+ NEXT_INST_V(1, 3, 1);
+ }
+ 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.
+ */
+
+ Tcl_AppendUnicodeToObj(objResultPtr, p, ustring1 - p);
+ }
+ TRACE_WITH_OBJ(("%.20s %.20s %.20s => ",
+ O2S(value2Ptr), O2S(value3Ptr), O2S(valuePtr)), objResultPtr);
+ NEXT_INST_V(1, 3, 1);
+
+ case INST_STR_FIND:
+ ustring1 = Tcl_GetUnicodeFromObj(OBJ_AT_TOS, &length); /* Haystack */
+ ustring2 = Tcl_GetUnicodeFromObj(OBJ_UNDER_TOS, &length2);/* Needle */
+
+ 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;
+ }
+ }
+ }
+
+ 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_MATCH:
nocase = TclGetInt1AtPtr(pc+1);
valuePtr = OBJ_AT_TOS; /* String */
value2Ptr = OBJ_UNDER_TOS; /* Pattern */
@@ -4416,19 +5209,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 ((valuePtr->typePtr == &tclByteArrayType) && !nocase) {
- unsigned char *string1, *string2;
- int length1, length2;
+ } else if (TclIsPureByteArray(valuePtr) && !nocase) {
+ unsigned char *bytes1, *bytes2;
- string1 = Tcl_GetByteArrayFromObj(valuePtr, &length1);
- string2 = Tcl_GetByteArrayFromObj(value2Ptr, &length2);
- match = TclByteArrayMatch(string1, length1, string2, length2, 0);
+ 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);
@@ -4437,64 +5228,105 @@ 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 = constants[match];
- NEXT_INST_F(2, 2, 1);
- }
- case INST_REGEXP: {
- int cflags, match;
- Tcl_Obj *valuePtr, *value2Ptr;
- Tcl_RegExp regExpr;
+ /*
+ * Peep-hole optimisation: if you're about to jump, do jump from here.
+ */
+
+ pc += 2;
+#ifndef TCL_COMPILE_DEBUG
+ switch (*pc) {
+ case INST_JUMP_FALSE1:
+ NEXT_INST_F((match? 2 : TclGetInt1AtPtr(pc+1)), 2, 0);
+ case INST_JUMP_TRUE1:
+ NEXT_INST_F((match? TclGetInt1AtPtr(pc+1) : 2), 2, 0);
+ case INST_JUMP_FALSE4:
+ NEXT_INST_F((match? 5 : TclGetInt4AtPtr(pc+1)), 2, 0);
+ case INST_JUMP_TRUE4:
+ NEXT_INST_F((match? TclGetInt4AtPtr(pc+1) : 5), 2, 0);
+ }
+#endif
+ objResultPtr = TCONST(match);
+ NEXT_INST_F(0, 2, 1);
+ case INST_REGEXP:
cflags = TclGetInt1AtPtr(pc+1); /* RE compile flages like NOCASE */
valuePtr = OBJ_AT_TOS; /* String */
value2Ptr = OBJ_UNDER_TOS; /* Pattern */
- regExpr = Tcl_GetRegExpFromObj(interp, value2Ptr, cflags);
- if (regExpr == NULL) {
- match = -1;
- } else {
+ /*
+ * Compile and match the regular expression.
+ */
+
+ {
+ Tcl_RegExp regExpr =
+ Tcl_GetRegExpFromObj(interp, value2Ptr, cflags);
+
+ if (regExpr == NULL) {
+ goto regexpFailure;
+ }
+
match = Tcl_RegExpExecObj(interp, regExpr, valuePtr, 0, 0, 0);
+
+ if (match < 0) {
+ regexpFailure:
+#ifdef TCL_COMPILE_DEBUG
+ objResultPtr = Tcl_GetObjResult(interp);
+ TRACE_WITH_OBJ(("%.20s %.20s => ERROR: ",
+ O2S(valuePtr), O2S(value2Ptr)), objResultPtr);
+#endif
+ goto gotError;
+ }
}
+ TRACE(("%.20s %.20s => %d\n", O2S(valuePtr), O2S(value2Ptr), match));
+
/*
- * Adjustment is 2 due to the nocase byte
+ * Peep-hole optimisation: if you're about to jump, do jump from here.
+ * Adjustment is 2 due to the nocase byte.
*/
- if (match < 0) {
- objResultPtr = Tcl_GetObjResult(interp);
- TRACE_WITH_OBJ(("%.20s %.20s => ERROR: ",
- O2S(valuePtr), O2S(value2Ptr)), objResultPtr);
- result = TCL_ERROR;
- goto checkForCatch;
- } else {
- TRACE(("%.20s %.20s => %d\n",
- O2S(valuePtr), O2S(value2Ptr), match));
- objResultPtr = constants[match];
- NEXT_INST_F(2, 2, 1);
+ pc += 2;
+#ifndef TCL_COMPILE_DEBUG
+ switch (*pc) {
+ case INST_JUMP_FALSE1:
+ NEXT_INST_F((match? 2 : TclGetInt1AtPtr(pc+1)), 2, 0);
+ case INST_JUMP_TRUE1:
+ NEXT_INST_F((match? TclGetInt1AtPtr(pc+1) : 2), 2, 0);
+ case INST_JUMP_FALSE4:
+ NEXT_INST_F((match? 5 : TclGetInt4AtPtr(pc+1)), 2, 0);
+ case INST_JUMP_TRUE4:
+ NEXT_INST_F((match? TclGetInt4AtPtr(pc+1) : 5), 2, 0);
}
+#endif
+ objResultPtr = TCONST(match);
+ NEXT_INST_F(0, 2, 1);
}
+ /*
+ * End of string-related instructions.
+ * -----------------------------------------------------------------
+ * Start of numeric operator instructions.
+ */
+
+ {
+ ClientData ptr1, ptr2;
+ int type1, type2;
+ long l1, l2, lResult;
+
case INST_EQ:
case INST_NEQ:
case INST_LT:
case INST_GT:
case INST_LE:
case INST_GE: {
- Tcl_Obj *valuePtr = OBJ_UNDER_TOS;
- Tcl_Obj *value2Ptr = OBJ_AT_TOS;
- ClientData ptr1, ptr2;
- int iResult = 0, compare = 0, type1, type2;
- double d1, d2, tmp;
- long l1, l2;
- mp_int big1, big2;
-#ifndef NO_WIDE_TYPE
- Tcl_WideInt w1, w2;
-#endif
+ int iResult = 0, compare = 0;
+
+ value2Ptr = OBJ_AT_TOS;
+ valuePtr = OBJ_UNDER_TOS;
if (GetNumberFromObj(NULL, valuePtr, &ptr1, &type1) != TCL_OK) {
/*
@@ -4530,222 +5362,12 @@ TclExecuteByteCode(
iResult = (*pc == INST_NEQ);
goto foundResult;
}
- switch (type1) {
- case TCL_NUMBER_LONG:
+ if ((type1 == TCL_NUMBER_LONG) && (type2 == TCL_NUMBER_LONG)) {
l1 = *((const long *)ptr1);
- switch (type2) {
- case TCL_NUMBER_LONG:
- l2 = *((const long *)ptr2);
- longCompare:
- compare = (l1 < l2) ? MP_LT : ((l1 > l2) ? MP_GT : MP_EQ);
- break;
-#ifndef NO_WIDE_TYPE
- case TCL_NUMBER_WIDE:
- w2 = *((const Tcl_WideInt *)ptr2);
- w1 = (Tcl_WideInt)l1;
- goto wideCompare;
-#endif
- case TCL_NUMBER_DOUBLE:
- d2 = *((const double *)ptr2);
- d1 = (double) l1;
-
- /*
- * If the double has a fractional part, or if the long can be
- * converted to double without loss of precision, then compare
- * as doubles.
- */
-
- if (DBL_MANT_DIG > CHAR_BIT*sizeof(long)
- || l1 == (long) d1
- || modf(d2, &tmp) != 0.0) {
- goto doubleCompare;
- }
-
- /*
- * Otherwise, to make comparision based on full precision,
- * need to convert the double to a suitably sized integer.
- *
- * Need this to get comparsions like
- * expr 20000000000000003 < 20000000000000004.0
- * right. Converting the first argument to double will yield
- * two double values that are equivalent within double
- * precision. Converting the double to an integer gets done
- * exactly, then integer comparison can tell the difference.
- */
-
- if (d2 < (double)LONG_MIN) {
- compare = MP_GT;
- break;
- }
- if (d2 > (double)LONG_MAX) {
- compare = MP_LT;
- break;
- }
- l2 = (long) d2;
- goto longCompare;
- case TCL_NUMBER_BIG:
- Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2);
- if (mp_cmp_d(&big2, 0) == MP_LT) {
- compare = MP_GT;
- } else {
- compare = MP_LT;
- }
- mp_clear(&big2);
- }
- break;
-
-#ifndef NO_WIDE_TYPE
- case TCL_NUMBER_WIDE:
- w1 = *((const Tcl_WideInt *)ptr1);
- switch (type2) {
- case TCL_NUMBER_WIDE:
- w2 = *((const Tcl_WideInt *)ptr2);
- wideCompare:
- compare = (w1 < w2) ? MP_LT : ((w1 > w2) ? MP_GT : MP_EQ);
- break;
- case TCL_NUMBER_LONG:
- l2 = *((const long *)ptr2);
- w2 = (Tcl_WideInt)l2;
- goto wideCompare;
- case TCL_NUMBER_DOUBLE:
- d2 = *((const double *)ptr2);
- d1 = (double) w1;
- if (DBL_MANT_DIG > CHAR_BIT*sizeof(Tcl_WideInt)
- || w1 == (Tcl_WideInt) d1
- || modf(d2, &tmp) != 0.0) {
- goto doubleCompare;
- }
- if (d2 < (double)LLONG_MIN) {
- compare = MP_GT;
- break;
- }
- if (d2 > (double)LLONG_MAX) {
- compare = MP_LT;
- break;
- }
- w2 = (Tcl_WideInt) d2;
- goto wideCompare;
- case TCL_NUMBER_BIG:
- Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2);
- if (mp_cmp_d(&big2, 0) == MP_LT) {
- compare = MP_GT;
- } else {
- compare = MP_LT;
- }
- mp_clear(&big2);
- }
- break;
-#endif
-
- case TCL_NUMBER_DOUBLE:
- d1 = *((const double *)ptr1);
- switch (type2) {
- case TCL_NUMBER_DOUBLE:
- d2 = *((const double *)ptr2);
- doubleCompare:
- compare = (d1 < d2) ? MP_LT : ((d1 > d2) ? MP_GT : MP_EQ);
- break;
- case TCL_NUMBER_LONG:
- l2 = *((const long *)ptr2);
- d2 = (double) l2;
- if (DBL_MANT_DIG > CHAR_BIT*sizeof(long)
- || l2 == (long) d2
- || modf(d1, &tmp) != 0.0) {
- goto doubleCompare;
- }
- if (d1 < (double)LONG_MIN) {
- compare = MP_LT;
- break;
- }
- if (d1 > (double)LONG_MAX) {
- compare = MP_GT;
- break;
- }
- l1 = (long) d1;
- goto longCompare;
-#ifndef NO_WIDE_TYPE
- case TCL_NUMBER_WIDE:
- w2 = *((const Tcl_WideInt *)ptr2);
- d2 = (double) w2;
- if (DBL_MANT_DIG > CHAR_BIT*sizeof(Tcl_WideInt)
- || w2 == (Tcl_WideInt) d2
- || modf(d1, &tmp) != 0.0) {
- goto doubleCompare;
- }
- if (d1 < (double)LLONG_MIN) {
- compare = MP_LT;
- break;
- }
- if (d1 > (double)LLONG_MAX) {
- compare = MP_GT;
- break;
- }
- w1 = (Tcl_WideInt) d1;
- goto wideCompare;
-#endif
- case TCL_NUMBER_BIG:
- if (TclIsInfinite(d1)) {
- compare = (d1 > 0.0) ? MP_GT : MP_LT;
- break;
- }
- Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2);
- if ((d1 < (double)LONG_MAX) && (d1 > (double)LONG_MIN)) {
- if (mp_cmp_d(&big2, 0) == MP_LT) {
- compare = MP_GT;
- } else {
- compare = MP_LT;
- }
- mp_clear(&big2);
- break;
- }
- if (DBL_MANT_DIG > CHAR_BIT*sizeof(long)
- && modf(d1, &tmp) != 0.0) {
- d2 = TclBignumToDouble(&big2);
- mp_clear(&big2);
- goto doubleCompare;
- }
- Tcl_InitBignumFromDouble(NULL, d1, &big1);
- goto bigCompare;
- }
- break;
-
- case TCL_NUMBER_BIG:
- Tcl_TakeBignumFromObj(NULL, valuePtr, &big1);
- switch (type2) {
-#ifndef NO_WIDE_TYPE
- case TCL_NUMBER_WIDE:
-#endif
- case TCL_NUMBER_LONG:
- compare = mp_cmp_d(&big1, 0);
- mp_clear(&big1);
- break;
- case TCL_NUMBER_DOUBLE:
- d2 = *((const double *)ptr2);
- if (TclIsInfinite(d2)) {
- compare = (d2 > 0.0) ? MP_LT : MP_GT;
- mp_clear(&big1);
- break;
- }
- if ((d2 < (double)LONG_MAX) && (d2 > (double)LONG_MIN)) {
- compare = mp_cmp_d(&big1, 0);
- mp_clear(&big1);
- break;
- }
- if (DBL_MANT_DIG > CHAR_BIT*sizeof(long)
- && modf(d2, &tmp) != 0.0) {
- d1 = TclBignumToDouble(&big1);
- mp_clear(&big1);
- goto doubleCompare;
- }
- Tcl_InitBignumFromDouble(NULL, d2, &big2);
- goto bigCompare;
- case TCL_NUMBER_BIG:
- Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2);
- bigCompare:
- compare = mp_cmp(&big1, &big2);
- mp_clear(&big1);
- mp_clear(&big2);
- }
+ l2 = *((const long *)ptr2);
+ compare = (l1 < l2) ? MP_LT : ((l1 > l2) ? MP_GT : MP_EQ);
+ } else {
+ compare = TclCompareTwoNumbers(valuePtr, value2Ptr);
}
/*
@@ -4792,745 +5414,256 @@ TclExecuteByteCode(
NEXT_INST_F((iResult? TclGetInt4AtPtr(pc+1) : 5), 2, 0);
}
#endif
- objResultPtr = constants[iResult];
+ objResultPtr = TCONST(iResult);
NEXT_INST_F(0, 2, 1);
}
case INST_MOD:
case INST_LSHIFT:
- case INST_RSHIFT: {
- Tcl_Obj *value2Ptr = OBJ_AT_TOS;
- Tcl_Obj *valuePtr = OBJ_UNDER_TOS;
- ClientData ptr1, ptr2;
- int invalid, shift, type1, type2;
- long l1 = 0;
+ 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);
CACHE_STACK_INFO();
- goto checkForCatch;
+ 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);
CACHE_STACK_INFO();
- goto checkForCatch;
+ goto gotError;
}
- if (*pc == INST_MOD) {
- /* TODO: Attempts to re-use unshared operands on stack */
+ /*
+ * Check for common, simple case.
+ */
- long l2 = 0; /* silence gcc warning */
+ if ((type1 == TCL_NUMBER_LONG) && (type2 == TCL_NUMBER_LONG)) {
+ l1 = *((const long *)ptr1);
+ l2 = *((const long *)ptr2);
- if (type2 == TCL_NUMBER_LONG) {
- l2 = *((const long *)ptr2);
+ switch (*pc) {
+ case INST_MOD:
if (l2 == 0) {
TRACE(("%s %s => DIVIDE BY ZERO\n", O2S(valuePtr),
O2S(value2Ptr)));
goto divideByZero;
- }
- if ((l2 == 1) || (l2 == -1)) {
+ } else if ((l2 == 1) || (l2 == -1)) {
/*
* Div. by |1| always yields remainder of 0.
*/
- objResultPtr = constants[0];
+ 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) {
- l1 = *((const long *)ptr1);
- if (l1 == 0) {
+ } else if (l1 == 0) {
/*
* 0 % (non-zero) always yields remainder of 0.
*/
- objResultPtr = constants[0];
+ TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr)));
+ objResultPtr = TCONST(0);
TRACE(("%s\n", O2S(objResultPtr)));
NEXT_INST_F(1, 2, 1);
- }
- if (type2 == TCL_NUMBER_LONG) {
- /*
- * Both operands are long; do native calculation.
- */
-
- long lRemainder, lQuotient = l1 / l2;
+ } else {
+ lResult = l1 / l2;
/*
* Force Tcl's integer division rules.
* TODO: examine for logic simplification
*/
- if ((lQuotient < 0 || (lQuotient == 0 &&
+ if ((lResult < 0 || (lResult == 0 &&
((l1 < 0 && l2 > 0) || (l1 > 0 && l2 < 0)))) &&
- (lQuotient * l2 != l1)) {
- lQuotient -= 1;
+ (lResult * l2 != l1)) {
+ lResult -= 1;
}
- lRemainder = l1 - l2*lQuotient;
- TclNewLongObj(objResultPtr, lRemainder);
- TRACE(("%s\n", O2S(objResultPtr)));
- NEXT_INST_F(1, 2, 1);
+ lResult = l1 - l2*lResult;
+ goto longResultOfArithmetic;
}
- /*
- * First operand fits in long; second does not, so the second
- * has greater magnitude than first. No need to divide to
- * determine the remainder.
- */
-
-#ifndef NO_WIDE_TYPE
- if (type2 == TCL_NUMBER_WIDE) {
- Tcl_WideInt w2 = *((const Tcl_WideInt *)ptr2);
-
- if ((l1 > 0) ^ (w2 > (Tcl_WideInt)0)) {
- /*
- * Arguments are opposite sign; remainder is sum.
- */
-
- objResultPtr = Tcl_NewWideIntObj(w2+(Tcl_WideInt)l1);
- TRACE(("%s\n", O2S(objResultPtr)));
- NEXT_INST_F(1, 2, 1);
- }
-
- /*
- * Arguments are same sign; remainder is first operand.
- */
-
- TRACE(("%s\n", O2S(valuePtr)));
- NEXT_INST_F(1, 1, 0);
- }
+ case INST_RSHIFT:
+ if (l2 < 0) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "negative shift argument", -1));
+#if 0
+ DECACHE_STACK_INFO();
+ Tcl_SetErrorCode(interp, "ARITH", "DOMAIN",
+ "domain error: argument not in valid range",
+ NULL);
+ CACHE_STACK_INFO();
#endif
- {
- mp_int big2;
-
- Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2);
-
- /* TODO: internals intrusion */
- if ((l1 > 0) ^ (big2.sign == MP_ZPOS)) {
- /*
- * Arguments are opposite sign; remainder is sum.
- */
-
- mp_int big1;
-
- TclBNInitBignumFromLong(&big1, l1);
- mp_add(&big2, &big1, &big2);
- mp_clear(&big1);
- objResultPtr = Tcl_NewBignumObj(&big2);
- TRACE(("%s\n", O2S(objResultPtr)));
- NEXT_INST_F(1, 2, 1);
- }
-
- /*
- * Arguments are same sign; remainder is first operand.
- */
-
- mp_clear(&big2);
- TRACE(("%s\n", O2S(valuePtr)));
- NEXT_INST_F(1, 1, 0);
- }
- }
-#ifndef NO_WIDE_TYPE
- if (type1 == TCL_NUMBER_WIDE) {
- Tcl_WideInt w1 = *((const Tcl_WideInt *)ptr1);
-
- if (type2 != TCL_NUMBER_BIG) {
- Tcl_WideInt w2, wQuotient, wRemainder;
-
- Tcl_GetWideIntFromObj(NULL, value2Ptr, &w2);
- wQuotient = w1 / w2;
-
- /*
- * Force Tcl's integer division rules.
- * TODO: examine for logic simplification
- */
-
- if (((wQuotient < (Tcl_WideInt) 0)
- || ((wQuotient == (Tcl_WideInt) 0)
- && ((w1 < (Tcl_WideInt)0 && w2 > (Tcl_WideInt)0)
- || (w1 > (Tcl_WideInt)0 && w2 < (Tcl_WideInt)0))))
- && (wQuotient * w2 != w1)) {
- wQuotient -= (Tcl_WideInt) 1;
- }
- wRemainder = w1 - w2*wQuotient;
- objResultPtr = Tcl_NewWideIntObj(wRemainder);
+ 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);
- }
- {
- mp_int big2;
- Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2);
+ } else {
+ /*
+ * Quickly force large right shifts to 0 or -1.
+ */
- /* TODO: internals intrusion */
- if ((w1 > ((Tcl_WideInt) 0)) ^ (big2.sign == MP_ZPOS)) {
+ if (l2 >= (long)(CHAR_BIT*sizeof(long))) {
/*
- * Arguments are opposite sign; remainder is sum.
+ * 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...
*/
- mp_int big1;
-
- TclBNInitBignumFromWideInt(&big1, w1);
- mp_add(&big2, &big1, &big2);
- mp_clear(&big1);
- objResultPtr = Tcl_NewBignumObj(&big2);
+ 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);
}
/*
- * Arguments are same sign; remainder is first operand.
+ * Handle shifts within the native long range.
*/
- mp_clear(&big2);
- TRACE(("%s\n", O2S(valuePtr)));
- NEXT_INST_F(1, 1, 0);
+ lResult = l1 >> ((int) l2);
+ goto longResultOfArithmetic;
}
- }
-#endif
- {
- mp_int big1, big2, bigResult, bigRemainder;
-
- Tcl_GetBignumFromObj(NULL, valuePtr, &big1);
- Tcl_GetBignumFromObj(NULL, value2Ptr, &big2);
- mp_init(&bigResult);
- mp_init(&bigRemainder);
- mp_div(&big1, &big2, &bigResult, &bigRemainder);
- if (!mp_iszero(&bigRemainder)
- && (bigRemainder.sign != big2.sign)) {
- /*
- * Convert to Tcl's integer division rules.
- */
- mp_sub_d(&bigResult, 1, &bigResult);
- mp_add(&bigRemainder, &big2, &bigRemainder);
- }
- mp_copy(&bigRemainder, &bigResult);
- mp_clear(&bigRemainder);
- mp_clear(&big1);
- mp_clear(&big2);
- TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr)));
- if (Tcl_IsShared(valuePtr)) {
- objResultPtr = Tcl_NewBignumObj(&bigResult);
- TRACE(("%s\n", O2S(objResultPtr)));
- NEXT_INST_F(1, 2, 1);
- }
- Tcl_SetBignumObj(valuePtr, &bigResult);
- TRACE(("%s\n", O2S(valuePtr)));
- NEXT_INST_F(1, 1, 0);
- }
- }
-
- /*
- * Reject negative shift argument.
- */
-
- switch (type2) {
- case TCL_NUMBER_LONG:
- invalid = (*((const long *)ptr2) < (long)0);
- break;
-#ifndef NO_WIDE_TYPE
- case TCL_NUMBER_WIDE:
- invalid = (*((const Tcl_WideInt *)ptr2) < (Tcl_WideInt)0);
- break;
+ case INST_LSHIFT:
+ if (l2 < 0) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "negative shift argument", -1));
+#if 0
+ DECACHE_STACK_INFO();
+ Tcl_SetErrorCode(interp, "ARITH", "DOMAIN",
+ "domain error: argument not in valid range",
+ NULL);
+ CACHE_STACK_INFO();
#endif
- case TCL_NUMBER_BIG: {
- mp_int big2;
-
- Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2);
- invalid = (mp_cmp_d(&big2, 0) == MP_LT);
- mp_clear(&big2);
- break;
- }
- default:
- /* Unused, here to silence compiler warning */
- invalid = 0;
- }
- if (invalid) {
- Tcl_SetObjResult(interp,
- Tcl_NewStringObj("negative shift argument", -1));
- result = TCL_ERROR;
- goto checkForCatch;
- }
-
- /*
- * Zero shifted any number of bits is still zero.
- */
-
- if ((type1==TCL_NUMBER_LONG) && (*((const long *)ptr1) == (long)0)) {
- TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr)));
- objResultPtr = constants[0];
- TRACE(("%s\n", O2S(objResultPtr)));
- NEXT_INST_F(1, 2, 1);
- }
-
- if (*pc == INST_LSHIFT) {
- /*
- * Large left shifts create integer overflow.
- *
- * BEWARE! Can't use Tcl_GetIntFromObj() here because that
- * converts values in the (unsigned) range to their signed int
- * counterparts, leading to incorrect results.
- */
-
- if ((type2 != TCL_NUMBER_LONG)
- || (*((const long *)ptr2) > (long) INT_MAX)) {
- /*
- * 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));
- result = TCL_ERROR;
- goto checkForCatch;
- }
- shift = (int)(*((const long *)ptr2));
-
- /*
- * Handle shifts within the native long range.
- */
-
- TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr)));
- if ((type1 == TCL_NUMBER_LONG)
- && (size_t) shift < CHAR_BIT*sizeof(long)
- && ((l1 = *(const long *)ptr1) != 0)
- && !((l1>0 ? l1 : ~l1)
- & -(1L<<(CHAR_BIT*sizeof(long) - 1 - shift)))) {
- TclNewLongObj(objResultPtr, (l1<<shift));
- TRACE(("%s\n", O2S(objResultPtr)));
- NEXT_INST_F(1, 2, 1);
- }
-
- /*
- * Handle shifts within the native wide range.
- */
-
- TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr)));
- if ((type1 != TCL_NUMBER_BIG)
- && ((size_t)shift < CHAR_BIT*sizeof(Tcl_WideInt))) {
- Tcl_WideInt w;
-
- TclGetWideIntFromObj(NULL, valuePtr, &w);
- if (!((w>0 ? w : ~w)
- & -(((Tcl_WideInt)1)
- << (CHAR_BIT*sizeof(Tcl_WideInt) - 1 - shift)))) {
- objResultPtr = Tcl_NewWideIntObj(w<<shift);
+ 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.
- */
-
- TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr)));
- if ((type2 != TCL_NUMBER_LONG)
- || (*(const long *)ptr2 > INT_MAX)) {
- /*
- * Again, technically, the value to be shifted could be an
- * mp_int so huge that a right shift by (INT_MAX+1) bits could
- * not take us to the result of 0 or -1, but since we're using
- * mp_div_2d to do the work, and it takes only an int
- * argument, we draw the line there.
- */
-
- int zero;
-
- switch (type1) {
- case TCL_NUMBER_LONG:
- zero = (*(const long *)ptr1 > 0L);
- break;
-#ifndef NO_WIDE_TYPE
- case TCL_NUMBER_WIDE:
- zero = (*(const Tcl_WideInt *)ptr1 > (Tcl_WideInt)0);
- break;
-#endif
- case TCL_NUMBER_BIG: {
- mp_int big1;
- Tcl_TakeBignumFromObj(NULL, valuePtr, &big1);
- zero = (mp_cmp_d(&big1, 0) == MP_GT);
- mp_clear(&big1);
- break;
- }
- default:
- /* Unused, here to silence compiler warning. */
- zero = 0;
- }
- if (zero) {
- objResultPtr = constants[0];
- } else {
- TclNewIntObj(objResultPtr, -1);
- }
- TRACE(("%s\n", O2S(objResultPtr)));
- NEXT_INST_F(1, 2, 1);
- }
- shift = (int)(*(const long *)ptr2);
-
- /*
- * Handle shifts within the native long range.
- */
-
- if (type1 == TCL_NUMBER_LONG) {
- l1 = *((const long *)ptr1);
- if ((size_t)shift >= CHAR_BIT*sizeof(long)) {
- if (l1 >= (long)0) {
- objResultPtr = constants[0];
- } else {
- TclNewIntObj(objResultPtr, -1);
- }
- } else {
- TclNewLongObj(objResultPtr, (l1 >> shift));
- }
- TRACE(("%s\n", O2S(objResultPtr)));
- NEXT_INST_F(1, 2, 1);
- }
-
-#ifndef NO_WIDE_TYPE
- /*
- * Handle shifts within the native wide range.
- */
-
- if (type1 == TCL_NUMBER_WIDE) {
- Tcl_WideInt w = *(const Tcl_WideInt *)ptr1;
-
- if ((size_t)shift >= CHAR_BIT*sizeof(Tcl_WideInt)) {
- if (w >= (Tcl_WideInt)0) {
- objResultPtr = constants[0];
- } else {
- TclNewIntObj(objResultPtr, -1);
- }
- } else {
- objResultPtr = Tcl_NewWideIntObj(w >> shift);
- }
- TRACE(("%s\n", O2S(objResultPtr)));
- NEXT_INST_F(1, 2, 1);
- }
-#endif
- }
-
- {
- mp_int big, bigResult, bigRemainder;
-
- Tcl_TakeBignumFromObj(NULL, valuePtr, &big);
-
- mp_init(&bigResult);
- if (*pc == INST_LSHIFT) {
- mp_mul_2d(&big, shift, &bigResult);
- } else {
- mp_init(&bigRemainder);
- mp_div_2d(&big, shift, &bigResult, &bigRemainder);
- if (mp_cmp_d(&bigRemainder, 0) == MP_LT) {
- /*
- * Convert to Tcl's integer division rules.
- */
-
- mp_sub_d(&bigResult, 1, &bigResult);
- }
- mp_clear(&bigRemainder);
- }
- mp_clear(&big);
-
- if (!Tcl_IsShared(valuePtr)) {
- Tcl_SetBignumObj(valuePtr, &bigResult);
- TRACE(("%s\n", O2S(valuePtr)));
- NEXT_INST_F(1, 1, 0);
- }
- objResultPtr = Tcl_NewBignumObj(&bigResult);
- }
- TRACE(("%s\n", O2S(objResultPtr)));
- NEXT_INST_F(1, 2, 1);
- }
-
- case INST_BITOR:
- case INST_BITXOR:
- case INST_BITAND: {
- ClientData ptr1, ptr2;
- int type1, type2;
- Tcl_Obj *value2Ptr = OBJ_AT_TOS;
- Tcl_Obj *valuePtr = OBJ_UNDER_TOS;
-
- result = GetNumberFromObj(NULL, valuePtr, &ptr1, &type1);
- if ((result != TCL_OK)
- || (type1 == TCL_NUMBER_NAN)
- || (type1 == TCL_NUMBER_DOUBLE)) {
- result = TCL_ERROR;
- TRACE(("%.20s %.20s => ILLEGAL 1st TYPE %s\n", O2S(valuePtr),
- O2S(value2Ptr), (valuePtr->typePtr?
- valuePtr->typePtr->name : "null")));
- DECACHE_STACK_INFO();
- IllegalExprOperandType(interp, pc, valuePtr);
- CACHE_STACK_INFO();
- goto checkForCatch;
- }
- result = GetNumberFromObj(NULL, value2Ptr, &ptr2, &type2);
- if ((result != TCL_OK) || (type2 == TCL_NUMBER_NAN)
- || (type2 == TCL_NUMBER_DOUBLE)) {
- result = TCL_ERROR;
- TRACE(("%.20s %.20s => ILLEGAL 2nd TYPE %s\n", O2S(valuePtr),
- O2S(value2Ptr), (value2Ptr->typePtr?
- value2Ptr->typePtr->name : "null")));
- DECACHE_STACK_INFO();
- IllegalExprOperandType(interp, pc, value2Ptr);
- CACHE_STACK_INFO();
- goto checkForCatch;
- }
-
- if ((type1 == TCL_NUMBER_BIG) || (type2 == TCL_NUMBER_BIG)) {
- mp_int big1, big2, bigResult, *First, *Second;
- int numPos;
-
- Tcl_TakeBignumFromObj(NULL, valuePtr, &big1);
- Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2);
-
- /*
- * Count how many positive arguments we have. If only one of the
- * arguments is negative, store it in 'Second'.
- */
-
- if (mp_cmp_d(&big1, 0) != MP_LT) {
- numPos = 1 + (mp_cmp_d(&big2, 0) != MP_LT);
- First = &big1;
- Second = &big2;
- } else {
- First = &big2;
- Second = &big1;
- numPos = (mp_cmp_d(First, 0) != MP_LT);
- }
- mp_init(&bigResult);
-
- switch (*pc) {
- case INST_BITAND:
- switch (numPos) {
- case 2:
- /*
- * Both arguments positive, base case.
- */
-
- mp_and(First, Second, &bigResult);
- break;
- case 1:
- /*
- * First is positive; second negative:
- * P & N = P & ~~N = P&~(-N-1) = P & (P ^ (-N-1))
- */
-
- mp_neg(Second, Second);
- mp_sub_d(Second, 1, Second);
- mp_xor(First, Second, &bigResult);
- mp_and(First, &bigResult, &bigResult);
- break;
- case 0:
- /*
- * Both arguments negative:
- * a & b = ~ (~a | ~b) = -(-a-1|-b-1)-1
- */
-
- mp_neg(First, First);
- mp_sub_d(First, 1, First);
- mp_neg(Second, Second);
- mp_sub_d(Second, 1, Second);
- mp_or(First, Second, &bigResult);
- mp_neg(&bigResult, &bigResult);
- mp_sub_d(&bigResult, 1, &bigResult);
- break;
- }
- break;
-
- case INST_BITOR:
- switch (numPos) {
- case 2:
- /*
- * Both arguments positive, base case.
- */
-
- mp_or(First, Second, &bigResult);
- break;
- case 1:
- /*
- * First is positive; second negative:
- * N|P = ~(~N&~P) = ~((-N-1)&~P) = -((-N-1)&((-N-1)^P))-1
- */
-
- mp_neg(Second, Second);
- mp_sub_d(Second, 1, Second);
- mp_xor(First, Second, &bigResult);
- mp_and(Second, &bigResult, &bigResult);
- mp_neg(&bigResult, &bigResult);
- mp_sub_d(&bigResult, 1, &bigResult);
- break;
- case 0:
- /*
- * Both arguments negative:
- * a | b = ~ (~a & ~b) = -(-a-1&-b-1)-1
- */
-
- mp_neg(First, First);
- mp_sub_d(First, 1, First);
- mp_neg(Second, Second);
- mp_sub_d(Second, 1, Second);
- mp_and(First, Second, &bigResult);
- mp_neg(&bigResult, &bigResult);
- mp_sub_d(&bigResult, 1, &bigResult);
- break;
- }
- break;
-
- case INST_BITXOR:
- switch (numPos) {
- case 2:
+ } else if (l2 > (long) INT_MAX) {
/*
- * Both arguments positive, base case.
+ * 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.
*/
- mp_xor(First, Second, &bigResult);
- break;
- case 1:
- /*
- * First is positive; second negative:
- * P^N = ~(P^~N) = -(P^(-N-1))-1
- */
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "integer value too large to represent", -1));
+#if 0
+ DECACHE_STACK_INFO();
+ Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW",
+ "integer value too large to represent", NULL);
+ CACHE_STACK_INFO();
+#endif
+ goto gotError;
+ } else {
+ int shift = (int) l2;
- 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)
+ * Handle shifts within the native long range.
*/
- 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;
+ 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;
+ }
}
- 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);
+ /*
+ * Too large; need to use the broken-out function.
+ */
- switch (*pc) {
- case INST_BITAND:
- wResult = w1 & w2;
- break;
- case INST_BITOR:
- wResult = w1 | w2;
- break;
- case INST_BITXOR:
- wResult = w1 ^ w2;
+ TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr)));
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;
+ goto longResultOfArithmetic;
case INST_BITOR:
lResult = l1 | l2;
- break;
+ goto longResultOfArithmetic;
case INST_BITXOR:
lResult = l1 ^ l2;
- break;
- default:
- /* Unused, here to silence compiler warning. */
- lResult = 0;
+ 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);
}
+ }
- 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)));
+ /*
+ * 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.
+ */
+
+ TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr)));
+ objResultPtr = ExecuteExtendedBinaryMathOp(interp, *pc, &TCONST(0),
+ valuePtr, value2Ptr);
+ if (objResultPtr == DIVIDED_BY_ZERO) {
+ TRACE_APPEND(("DIVIDE BY ZERO\n"));
+ goto divideByZero;
+ } else if (objResultPtr == GENERAL_ARITHMETIC_ERROR) {
+ TRACE_APPEND(("ERROR: %s\n",
+ TclGetString(Tcl_GetObjResult(interp))));
+ goto gotError;
+ } else if (objResultPtr == NULL) {
+ TRACE_APPEND(("%s\n", O2S(valuePtr)));
NEXT_INST_F(1, 1, 0);
+ } else {
+ TRACE_APPEND(("%s\n", O2S(objResultPtr)));
+ NEXT_INST_F(1, 2, 1);
}
- }
case INST_EXPON:
case INST_ADD:
case INST_SUB:
case INST_DIV:
- case INST_MULT: {
- ClientData ptr1, ptr2;
- int type1, type2;
- Tcl_Obj *value2Ptr = OBJ_AT_TOS;
- Tcl_Obj *valuePtr = OBJ_UNDER_TOS;
+ 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);
CACHE_STACK_INFO();
- goto checkForCatch;
+ goto gotError;
}
#ifdef ACCEPT_NAN
@@ -5543,20 +5676,15 @@ TclExecuteByteCode(
}
#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);
CACHE_STACK_INFO();
- goto checkForCatch;
+ goto gotError;
}
#ifdef ACCEPT_NAN
@@ -5570,911 +5698,242 @@ TclExecuteByteCode(
}
#endif
- if ((type1 == TCL_NUMBER_DOUBLE) || (type2 == TCL_NUMBER_DOUBLE)) {
- /*
- * At least one of the values is floating-point, so perform
- * floating point calculations.
- */
+ /*
+ * Handle (long,long) arithmetic as best we can without going out to
+ * an external function.
+ */
- double d1, d2, dResult;
+ if ((type1 == TCL_NUMBER_LONG) && (type2 == TCL_NUMBER_LONG)) {
+ Tcl_WideInt w1, w2, wResult;
- Tcl_GetDoubleFromObj(NULL, valuePtr, &d1);
- Tcl_GetDoubleFromObj(NULL, value2Ptr, &d2);
+ 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;
- 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;
- 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)));
- DECACHE_STACK_INFO();
- TclExprFloatError(interp, dResult);
- CACHE_STACK_INFO();
- result = TCL_ERROR;
- goto checkForCatch;
- }
-#endif
- TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr)));
- if (Tcl_IsShared(valuePtr)) {
- TclNewDoubleObj(objResultPtr, dResult);
- TRACE(("%s\n", O2S(objResultPtr)));
- NEXT_INST_F(1, 2, 1);
- }
- TclSetDoubleObj(valuePtr, dResult);
- TRACE(("%s\n", O2S(valuePtr)));
- NEXT_INST_F(1, 1, 0);
- }
-
- if ((sizeof(long) >= 2*sizeof(int)) && (*pc == INST_MULT)
- && (type1 == TCL_NUMBER_LONG) && (type2 == TCL_NUMBER_LONG)) {
- long l1 = *((const long *)ptr1);
- long l2 = *((const long *)ptr2);
-
- if ((l1 <= INT_MAX) && (l1 >= INT_MIN)
- && (l2 <= INT_MAX) && (l2 >= INT_MIN)) {
- long lResult = l1 * l2;
-
- 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 ((sizeof(Tcl_WideInt) >= 2*sizeof(long)) && (*pc == INST_MULT)
- && (type1 == TCL_NUMBER_LONG) && (type2 == TCL_NUMBER_LONG)) {
- Tcl_WideInt w1, w2, wResult;
- TclGetWideIntFromObj(NULL, valuePtr, &w1);
- TclGetWideIntFromObj(NULL, value2Ptr, &w2);
-
- wResult = w1 * w2;
-
- TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr)));
- if (Tcl_IsShared(valuePtr)) {
- objResultPtr = Tcl_NewWideIntObj(wResult);
- TRACE(("%s\n", O2S(objResultPtr)));
- NEXT_INST_F(1, 2, 1);
- }
- Tcl_SetWideIntObj(valuePtr, wResult);
- TRACE(("%s\n", O2S(valuePtr)));
- NEXT_INST_F(1, 1, 0);
- }
-
- /* TODO: Attempts to re-use unshared operands on stack. */
- if (*pc == INST_EXPON) {
- long l1 = 0, l2 = 0;
- int oddExponent = 0, negativeExponent = 0;
-#if (LONG_MAX > 0x7fffffff) || !defined(TCL_WIDE_INT_IS_LONG)
- Tcl_WideInt w1;
-#endif
-
- if (type2 == TCL_NUMBER_LONG) {
- l2 = *((const long *) ptr2);
- if (l2 == 0) {
- /*
- * Anything to the zero power is 1.
- */
-
- objResultPtr = constants[1];
- NEXT_INST_F(1, 2, 1);
- } else if (l2 == 1) {
- /*
- * Anything to the first power is itself
- */
- NEXT_INST_F(1, 1, 0);
+ if (Overflowing(w1, w2, wResult)) {
+ goto overflow;
}
- }
-
- switch (type2) {
- case TCL_NUMBER_LONG: {
- negativeExponent = (l2 < 0);
- oddExponent = (int) (l2 & 1);
- break;
- }
-#ifndef NO_WIDE_TYPE
- case TCL_NUMBER_WIDE: {
- Tcl_WideInt w2 = *((const Tcl_WideInt *)ptr2);
-
- negativeExponent = (w2 < 0);
- oddExponent = (int) (w2 & (Tcl_WideInt)1);
- break;
- }
#endif
- case TCL_NUMBER_BIG: {
- mp_int big2;
-
- Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2);
- negativeExponent = (mp_cmp_d(&big2, 0) == MP_LT);
- mp_mod_2d(&big2, 1, &big2);
- oddExponent = !mp_iszero(&big2);
- mp_clear(&big2);
- break;
- }
- }
-
- if (type1 == TCL_NUMBER_LONG) {
- l1 = *((const long *)ptr1);
- }
- if (negativeExponent) {
- if (type1 == TCL_NUMBER_LONG) {
- switch (l1) {
- case 0:
- /*
- * Zero to a negative power is div by zero error.
- */
-
- TRACE(("%s %s => EXPONENT OF ZERO\n", O2S(valuePtr),
- O2S(value2Ptr)));
- goto exponOfZero;
- case -1:
- if (oddExponent) {
- TclNewIntObj(objResultPtr, -1);
- } else {
- objResultPtr = constants[1];
- }
- NEXT_INST_F(1, 2, 1);
- case 1:
- /*
- * 1 to any power is 1.
- */
-
- objResultPtr = constants[1];
- NEXT_INST_F(1, 2, 1);
- }
- }
+ goto wideResultOfArithmetic;
+ case INST_SUB:
+ w1 = (Tcl_WideInt) l1;
+ w2 = (Tcl_WideInt) l2;
+ wResult = w1 - w2;
+#ifdef TCL_WIDE_INT_IS_LONG
/*
- * Integers with magnitude greater than 1 raise to a negative
- * power yield the answer zero (see TIP 123).
+ * 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.
*/
- objResultPtr = constants[0];
- NEXT_INST_F(1, 2, 1);
- }
-
- if (type1 == TCL_NUMBER_LONG) {
- switch (l1) {
- case 0:
- /*
- * Zero to a positive power is zero.
- */
-
- objResultPtr = constants[0];
- NEXT_INST_F(1, 2, 1);
- case 1:
- /*
- * 1 to any power is 1.
- */
-
- objResultPtr = constants[1];
- NEXT_INST_F(1, 2, 1);
- case -1:
- if (oddExponent) {
- TclNewIntObj(objResultPtr, -1);
- } else {
- objResultPtr = constants[1];
- }
- NEXT_INST_F(1, 2, 1);
- }
- }
- /*
- * We refuse to accept exponent arguments that exceed
- * one mp_digit which means the max exponent value is
- * 2**28-1 = 0x0fffffff = 268435455, which fits into
- * a signed 32 bit int which is within the range of the
- * long int type. This means any numeric Tcl_Obj value
- * not using TCL_NUMBER_LONG type must hold a value larger
- * than we accept.
- */
- if (type2 != TCL_NUMBER_LONG) {
- Tcl_SetObjResult(interp,
- Tcl_NewStringObj("exponent too large", -1));
- result = TCL_ERROR;
- goto checkForCatch;
- }
-
- if (type1 == TCL_NUMBER_LONG) {
- if (l1 == 2) {
- /*
- * Reduce small powers of 2 to shifts.
- */
-
- if ((unsigned long) l2 < CHAR_BIT * sizeof(long) - 1) {
- TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr)));
- TclNewLongObj(objResultPtr, (1L << l2));
- TRACE(("%s\n", O2S(objResultPtr)));
- NEXT_INST_F(1, 2, 1);
- }
-#if !defined(TCL_WIDE_INT_IS_LONG)
- if ((unsigned long)l2 < CHAR_BIT*sizeof(Tcl_WideInt) - 1){
- TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr)));
- objResultPtr =
- Tcl_NewWideIntObj(((Tcl_WideInt) 1) << l2);
- TRACE(("%s\n", O2S(objResultPtr)));
- NEXT_INST_F(1, 2, 1);
- }
-#endif
+ if (Overflowing(w1, ~w2, wResult)) {
goto overflow;
}
- if (l1 == -2) {
- int signum = oddExponent ? -1 : 1;
-
- /*
- * Reduce small powers of 2 to shifts.
- */
-
- if ((unsigned long) l2 < CHAR_BIT * sizeof(long) - 1) {
- TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr)));
- TclNewLongObj(objResultPtr, signum * (1L << l2));
- TRACE(("%s\n", O2S(objResultPtr)));
- NEXT_INST_F(1, 2, 1);
- }
-#if !defined(TCL_WIDE_INT_IS_LONG)
- if ((unsigned long)l2 < CHAR_BIT*sizeof(Tcl_WideInt) - 1){
- TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr)));
- objResultPtr = Tcl_NewWideIntObj(
- signum * (((Tcl_WideInt) 1) << l2));
- TRACE(("%s\n", O2S(objResultPtr)));
- NEXT_INST_F(1, 2, 1);
- }
#endif
- goto overflow;
- }
-#if (LONG_MAX == 0x7fffffff)
- if (l2 - 2 < (long)MaxBase32Size
- && l1 <= MaxBase32[l2 - 2]
- && l1 >= -MaxBase32[l2 - 2]) {
- /*
- * Small powers of 32-bit integers.
- */
-
- long lResult = l1 * l1; /* b**2 */
- switch (l2) {
- case 2:
- break;
- case 3:
- lResult *= l1; /* b**3 */
- break;
- case 4:
- lResult *= lResult; /* b**4 */
- break;
- case 5:
- lResult *= lResult; /* b**4 */
- lResult *= l1; /* b**5 */
- break;
- case 6:
- lResult *= l1; /* b**3 */
- lResult *= lResult; /* b**6 */
- break;
- case 7:
- lResult *= l1; /* b**3 */
- lResult *= lResult; /* b**6 */
- lResult *= l1; /* b**7 */
- break;
- case 8:
- lResult *= lResult; /* b**4 */
- lResult *= lResult; /* b**8 */
- break;
- }
- TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr)));
- if (Tcl_IsShared(valuePtr)) {
- TclNewLongObj(objResultPtr, lResult);
- TRACE(("%s\n", O2S(objResultPtr)));
- NEXT_INST_F(1, 2, 1);
- }
- Tcl_SetLongObj(valuePtr, lResult);
- TRACE(("%s\n", O2S(valuePtr)));
- NEXT_INST_F(1, 1, 0);
- }
- if (l1 - 3 >= 0 && l1 - 2 < (long)Exp32IndexSize
- && l2 - 2 < (long)(Exp32ValueSize + MaxBase32Size)) {
-
- unsigned short base = Exp32Index[l1 - 3]
- + (unsigned short) (l2 - 2 - MaxBase32Size);
- if (base < Exp32Index[l1 - 2]) {
- /*
- * 32-bit number raised to intermediate power, done by
- * table lookup.
- */
-
- TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr)));
- if (Tcl_IsShared(valuePtr)) {
- TclNewLongObj(objResultPtr, Exp32Value[base]);
- TRACE(("%s\n", O2S(objResultPtr)));
- NEXT_INST_F(1, 2, 1);
- }
- Tcl_SetLongObj(valuePtr, Exp32Value[base]);
- TRACE(("%s\n", O2S(valuePtr)));
- NEXT_INST_F(1, 1, 0);
- }
- }
- if (-l1 - 3 >= 0 && -l1 - 2 < (long)Exp32IndexSize
- && l2 - 2 < (long)(Exp32ValueSize + MaxBase32Size)) {
- unsigned short base = Exp32Index[-l1 - 3]
- + (unsigned short) (l2 - 2 - MaxBase32Size);
- if (base < Exp32Index[-l1 - 2]) {
- long lResult = (oddExponent) ?
- -Exp32Value[base] : Exp32Value[base];
-
- /*
- * 32-bit number raised to intermediate power, done by
- * table lookup.
- */
-
- TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr)));
- if (Tcl_IsShared(valuePtr)) {
- TclNewLongObj(objResultPtr, lResult);
- TRACE(("%s\n", O2S(objResultPtr)));
- NEXT_INST_F(1, 2, 1);
- }
- Tcl_SetLongObj(valuePtr, lResult);
- TRACE(("%s\n", O2S(valuePtr)));
- NEXT_INST_F(1, 1, 0);
- }
- }
-#endif
- }
-#if (LONG_MAX > 0x7fffffff) || !defined(TCL_WIDE_INT_IS_LONG)
- if (type1 == TCL_NUMBER_LONG) {
- w1 = l1;
-#ifndef NO_WIDE_TYPE
- } else if (type1 == TCL_NUMBER_WIDE) {
- w1 = *((const Tcl_WideInt*) ptr1);
-#endif
- } else {
- goto overflow;
- }
- if (l2 - 2 < (long)MaxBase64Size
- && w1 <= MaxBase64[l2 - 2]
- && w1 >= -MaxBase64[l2 - 2]) {
- /*
- * Small powers of integers whose result is wide.
- */
-
- Tcl_WideInt wResult = w1 * w1; /* b**2 */
-
- switch (l2) {
- case 2:
- break;
- case 3:
- wResult *= l1; /* b**3 */
- break;
- case 4:
- wResult *= wResult; /* b**4 */
- break;
- case 5:
- wResult *= wResult; /* b**4 */
- wResult *= w1; /* b**5 */
- break;
- case 6:
- wResult *= w1; /* b**3 */
- wResult *= wResult; /* b**6 */
- break;
- case 7:
- wResult *= w1; /* b**3 */
- wResult *= wResult; /* b**6 */
- wResult *= w1; /* b**7 */
- break;
- case 8:
- wResult *= wResult; /* b**4 */
- wResult *= wResult; /* b**8 */
- break;
- case 9:
- wResult *= wResult; /* b**4 */
- wResult *= wResult; /* b**8 */
- wResult *= w1; /* b**9 */
- break;
- case 10:
- wResult *= wResult; /* b**4 */
- wResult *= w1; /* b**5 */
- wResult *= wResult; /* b**10 */
- break;
- case 11:
- wResult *= wResult; /* b**4 */
- wResult *= w1; /* b**5 */
- wResult *= wResult; /* b**10 */
- wResult *= w1; /* b**11 */
- break;
- case 12:
- wResult *= w1; /* b**3 */
- wResult *= wResult; /* b**6 */
- wResult *= wResult; /* b**12 */
- break;
- case 13:
- wResult *= w1; /* b**3 */
- wResult *= wResult; /* b**6 */
- wResult *= wResult; /* b**12 */
- wResult *= w1; /* b**13 */
- break;
- case 14:
- wResult *= w1; /* b**3 */
- wResult *= wResult; /* b**6 */
- wResult *= w1; /* b**7 */
- wResult *= wResult; /* b**14 */
- break;
- case 15:
- wResult *= w1; /* b**3 */
- wResult *= wResult; /* b**6 */
- wResult *= w1; /* b**7 */
- wResult *= wResult; /* b**14 */
- wResult *= w1; /* b**15 */
- break;
- case 16:
- wResult *= wResult; /* b**4 */
- wResult *= wResult; /* b**8 */
- wResult *= wResult; /* b**16 */
- break;
-
- }
+ wideResultOfArithmetic:
TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr)));
- objResultPtr = Tcl_NewWideIntObj(wResult);
- TRACE(("%s\n", O2S(objResultPtr)));
- NEXT_INST_F(1, 2, 1);
- }
-
- /*
- * Handle cases of powers > 16 that still fit in a 64-bit word by
- * doing table lookup.
- */
- if (w1 - 3 >= 0 && w1 - 2 < (long)Exp64IndexSize
- && l2 - 2 < (long)(Exp64ValueSize + MaxBase64Size)) {
- unsigned short base = Exp64Index[w1 - 3]
- + (unsigned short) (l2 - 2 - MaxBase64Size);
-
- if (base < Exp64Index[w1 - 2]) {
- /*
- * 64-bit number raised to intermediate power, done by
- * table lookup.
- */
-
- TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr)));
- if (Tcl_IsShared(valuePtr)) {
- objResultPtr = Tcl_NewWideIntObj(Exp64Value[base]);
- TRACE(("%s\n", O2S(objResultPtr)));
- NEXT_INST_F(1, 2, 1);
- }
- Tcl_SetWideIntObj(valuePtr, Exp64Value[base]);
- TRACE(("%s\n", O2S(valuePtr)));
- NEXT_INST_F(1, 1, 0);
- }
- }
-
- if (-w1 - 3 >= 0 && -w1 - 2 < (long)Exp64IndexSize
- && l2 - 2 < (long)(Exp64ValueSize + MaxBase64Size)) {
- unsigned short base = Exp64Index[-w1 - 3]
- + (unsigned short) (l2 - 2 - MaxBase64Size);
-
- if (base < Exp64Index[-w1 - 2]) {
- Tcl_WideInt wResult = (oddExponent) ?
- -Exp64Value[base] : Exp64Value[base];
- /*
- * 64-bit number raised to intermediate power, done by
- * table lookup.
- */
-
- TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr)));
- if (Tcl_IsShared(valuePtr)) {
- objResultPtr = Tcl_NewWideIntObj(wResult);
- TRACE(("%s\n", O2S(objResultPtr)));
- NEXT_INST_F(1, 2, 1);
- }
- Tcl_SetWideIntObj(valuePtr, wResult);
- TRACE(("%s\n", O2S(valuePtr)));
- NEXT_INST_F(1, 1, 0);
- }
- }
-#endif
-
- goto overflow;
- }
-
- if ((*pc != INST_MULT)
- && (type1 != TCL_NUMBER_BIG) && (type2 != TCL_NUMBER_BIG)) {
- Tcl_WideInt w1, w2, wResult;
-
- TclGetWideIntFromObj(NULL, valuePtr, &w1);
- TclGetWideIntFromObj(NULL, value2Ptr, &w2);
-
- switch (*pc) {
- case INST_ADD:
- wResult = w1 + w2;
-#ifndef NO_WIDE_TYPE
- if ((type1 == TCL_NUMBER_WIDE) || (type2 == TCL_NUMBER_WIDE))
-#endif
- {
- /*
- * Check for overflow.
- */
-
- if (Overflowing(w1, w2, wResult)) {
- goto overflow;
- }
- }
- break;
-
- case INST_SUB:
- wResult = w1 - w2;
-#ifndef NO_WIDE_TYPE
- if ((type1 == TCL_NUMBER_WIDE) || (type2 == TCL_NUMBER_WIDE))
-#endif
- {
- /*
- * Must check for overflow. The macro tests for overflows
- * in sums by looking at the sign bits. As we have a
- * subtraction here, we are adding -w2. As -w2 could in
- * turn overflow, we test with ~w2 instead: it has the
- * opposite sign bit to w2 so it does the job. Note that
- * the only "bad" case (w2==0) is irrelevant for this
- * macro, as in that case w1 and wResult have the same
- * sign and there is no overflow anyway.
- */
-
- if (Overflowing(w1, ~w2, wResult)) {
- goto overflow;
- }
+ if (Tcl_IsShared(valuePtr)) {
+ objResultPtr = Tcl_NewWideIntObj(wResult);
+ TRACE(("%s\n", O2S(objResultPtr)));
+ NEXT_INST_F(1, 2, 1);
}
- break;
+ Tcl_SetWideIntObj(valuePtr, wResult);
+ TRACE(("%s\n", O2S(valuePtr)));
+ NEXT_INST_F(1, 1, 0);
case INST_DIV:
- if (w2 == 0) {
+ if (l2 == 0) {
TRACE(("%s %s => DIVIDE BY ZERO\n",
O2S(valuePtr), O2S(value2Ptr)));
goto divideByZero;
- }
-
- /*
- * Need a bignum to represent (LLONG_MIN / -1)
- */
+ } else if ((l1 == LONG_MIN) && (l2 == -1)) {
+ /*
+ * Can't represent (-LONG_MIN) as a long.
+ */
- if ((w1 == LLONG_MIN) && (w2 == -1)) {
goto overflow;
}
- wResult = w1 / w2;
+ lResult = l1 / l2;
/*
* Force Tcl's integer division rules.
* TODO: examine for logic simplification
*/
- if (((wResult < 0) || ((wResult == 0) &&
- ((w1 < 0 && w2 > 0) || (w1 > 0 && w2 < 0)))) &&
- ((wResult * w2) != w1)) {
- wResult -= 1;
+ if (((lResult < 0) || ((lResult == 0) &&
+ ((l1 < 0 && l2 > 0) || (l1 > 0 && l2 < 0)))) &&
+ ((lResult * l2) != l1)) {
+ lResult -= 1;
}
- break;
- default:
- /*
- * Unused, here to silence compiler warning.
- */
+ goto longResultOfArithmetic;
- wResult = 0;
+ 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;
+ }
}
- 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);
+ /*
+ * Fall through with INST_EXPON, INST_DIV and large multiplies.
+ */
}
overflow:
- {
- mp_int big1, big2, bigResult, bigRemainder;
-
- TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr)));
- Tcl_TakeBignumFromObj(NULL, valuePtr, &big1);
- Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2);
- mp_init(&bigResult);
- switch (*pc) {
- case INST_ADD:
- mp_add(&big1, &big2, &bigResult);
- break;
- case INST_SUB:
- mp_sub(&big1, &big2, &bigResult);
- break;
- case INST_MULT:
- mp_mul(&big1, &big2, &bigResult);
- break;
- case INST_DIV:
- if (mp_iszero(&big2)) {
- TRACE(("%s %s => DIVIDE BY ZERO\n", O2S(valuePtr),
- O2S(value2Ptr)));
- mp_clear(&big1);
- mp_clear(&big2);
- mp_clear(&bigResult);
- goto divideByZero;
- }
- mp_init(&bigRemainder);
- mp_div(&big1, &big2, &bigResult, &bigRemainder);
- /* TODO: internals intrusion */
- if (!mp_iszero(&bigRemainder)
- && (bigRemainder.sign != big2.sign)) {
- /*
- * Convert to Tcl's integer division rules.
- */
-
- mp_sub_d(&bigResult, 1, &bigResult);
- mp_add(&bigRemainder, &big2, &bigRemainder);
- }
- mp_clear(&bigRemainder);
- break;
- case INST_EXPON:
- if (big2.used > 1) {
- Tcl_SetObjResult(interp,
- Tcl_NewStringObj("exponent too large", -1));
- mp_clear(&big1);
- mp_clear(&big2);
- mp_clear(&bigResult);
- result = TCL_ERROR;
- goto checkForCatch;
- }
- mp_expt_d(&big1, big2.dp[0], &bigResult);
- break;
- }
- mp_clear(&big1);
- mp_clear(&big2);
- if (Tcl_IsShared(valuePtr)) {
- objResultPtr = Tcl_NewBignumObj(&bigResult);
- TRACE(("%s\n", O2S(objResultPtr)));
- NEXT_INST_F(1, 2, 1);
- }
- Tcl_SetBignumObj(valuePtr, &bigResult);
- TRACE(("%s\n", O2S(valuePtr)));
+ TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr)));
+ objResultPtr = ExecuteExtendedBinaryMathOp(interp, *pc, &TCONST(0),
+ valuePtr, value2Ptr);
+ if (objResultPtr == DIVIDED_BY_ZERO) {
+ TRACE_APPEND(("DIVIDE BY ZERO\n"));
+ goto divideByZero;
+ } else if (objResultPtr == EXPONENT_OF_ZERO) {
+ TRACE_APPEND(("EXPONENT OF ZERO\n"));
+ goto exponOfZero;
+ } else if (objResultPtr == GENERAL_ARITHMETIC_ERROR) {
+ TRACE_APPEND(("ERROR: %s\n",
+ TclGetString(Tcl_GetObjResult(interp))));
+ goto gotError;
+ } else if (objResultPtr == NULL) {
+ TRACE_APPEND(("%s\n", O2S(valuePtr)));
NEXT_INST_F(1, 1, 0);
+ } else {
+ TRACE_APPEND(("%s\n", O2S(objResultPtr)));
+ NEXT_INST_F(1, 2, 1);
}
- }
case INST_LNOT: {
int b;
- Tcl_Obj *valuePtr = OBJ_AT_TOS;
+
+ valuePtr = OBJ_AT_TOS;
/* TODO - check claim that taking address of b harms performance */
/* TODO - consider optimization search for constants */
- result = TclGetBooleanFromObj(NULL, valuePtr, &b);
- if (result != TCL_OK) {
+ if (TclGetBooleanFromObj(NULL, valuePtr, &b) != TCL_OK) {
TRACE(("\"%.20s\" => ILLEGAL TYPE %s\n", O2S(valuePtr),
(valuePtr->typePtr? valuePtr->typePtr->name : "null")));
DECACHE_STACK_INFO();
IllegalExprOperandType(interp, pc, valuePtr);
CACHE_STACK_INFO();
- goto checkForCatch;
+ goto gotError;
}
/* TODO: Consider peephole opt. */
- objResultPtr = constants[!b];
+ objResultPtr = TCONST(!b);
NEXT_INST_F(1, 1, 1);
}
- case INST_BITNOT: {
- mp_int big;
- ClientData ptr;
- int type;
- Tcl_Obj *valuePtr = OBJ_AT_TOS;
-
- result = GetNumberFromObj(NULL, valuePtr, &ptr, &type);
- if ((result != TCL_OK)
- || (type == TCL_NUMBER_NAN) || (type == TCL_NUMBER_DOUBLE)) {
+ case INST_BITNOT:
+ valuePtr = OBJ_AT_TOS;
+ if ((GetNumberFromObj(NULL, valuePtr, &ptr1, &type1) != TCL_OK)
+ || (type1==TCL_NUMBER_NAN) || (type1==TCL_NUMBER_DOUBLE)) {
/*
* ... ~$NonInteger => raise an error.
*/
- result = TCL_ERROR;
TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(valuePtr),
(valuePtr->typePtr? valuePtr->typePtr->name : "null")));
DECACHE_STACK_INFO();
IllegalExprOperandType(interp, pc, valuePtr);
CACHE_STACK_INFO();
- goto 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);
+ goto gotError;
}
-#ifndef NO_WIDE_TYPE
- if (type == TCL_NUMBER_WIDE) {
- 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);
NEXT_INST_F(1, 1, 1);
}
- Tcl_SetWideIntObj(valuePtr, ~w);
+ TclSetLongObj(valuePtr, ~l1);
NEXT_INST_F(1, 0, 0);
}
-#endif
- Tcl_TakeBignumFromObj(NULL, valuePtr, &big);
- /* ~a = - a - 1 */
- mp_neg(&big, &big);
- mp_sub_d(&big, 1, &big);
- if (Tcl_IsShared(valuePtr)) {
- objResultPtr = Tcl_NewBignumObj(&big);
+ objResultPtr = ExecuteExtendedUnaryMathOp(*pc, valuePtr);
+ if (objResultPtr != NULL) {
NEXT_INST_F(1, 1, 1);
+ } else {
+ 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 = OBJ_AT_TOS;
- result = GetNumberFromObj(NULL, valuePtr, &ptr, &type);
- if ((result != TCL_OK)
-#ifndef ACCEPT_NAN
- || (type == TCL_NUMBER_NAN)
-#endif
- ) {
- result = TCL_ERROR;
+ case INST_UMINUS:
+ valuePtr = OBJ_AT_TOS;
+ if ((GetNumberFromObj(NULL, valuePtr, &ptr1, &type1) != TCL_OK)
+ || IsErroringNaNType(type1)) {
TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(valuePtr),
(valuePtr->typePtr? valuePtr->typePtr->name : "null")));
DECACHE_STACK_INFO();
IllegalExprOperandType(interp, pc, valuePtr);
CACHE_STACK_INFO();
- goto checkForCatch;
+ 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 */
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);
NEXT_INST_F(1, 1, 1);
}
- Tcl_SetWideIntObj(valuePtr, -w);
+ TclSetLongObj(valuePtr, -l1);
NEXT_INST_F(1, 0, 0);
}
/* FALLTHROUGH */
}
-#endif
- case TCL_NUMBER_BIG: {
- mp_int big;
-
- switch (type) {
-#ifdef NO_WIDE_TYPE
- case TCL_NUMBER_LONG:
- TclBNInitBignumFromLong(&big, *(const long *) ptr);
- break;
-#else
- case TCL_NUMBER_WIDE:
- TclBNInitBignumFromWideInt(&big, *(const Tcl_WideInt *) ptr);
- break;
-#endif
- case TCL_NUMBER_BIG:
- Tcl_TakeBignumFromObj(NULL, valuePtr, &big);
- }
- mp_neg(&big, &big);
- if (Tcl_IsShared(valuePtr)) {
- objResultPtr = Tcl_NewBignumObj(&big);
- NEXT_INST_F(1, 1, 1);
- }
- Tcl_SetBignumObj(valuePtr, &big);
- NEXT_INST_F(1, 0, 0);
- }
- case TCL_NUMBER_NAN:
- /* -NaN => NaN */
+ objResultPtr = ExecuteExtendedUnaryMathOp(*pc, valuePtr);
+ if (objResultPtr != NULL) {
+ NEXT_INST_F(1, 1, 1);
+ } else {
NEXT_INST_F(1, 0, 0);
}
- }
case INST_UPLUS:
- case INST_TRY_CVT_TO_NUMERIC: {
+ case INST_TRY_CVT_TO_NUMERIC:
/*
* Try to convert the topmost stack object to numeric object. This is
* done in order to support [expr]'s policy of interpreting operands
* if at all possible as numbers first, then strings.
*/
- ClientData ptr;
- int type;
- Tcl_Obj *valuePtr = OBJ_AT_TOS;
+ valuePtr = OBJ_AT_TOS;
- 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")));
DECACHE_STACK_INFO();
IllegalExprOperandType(interp, pc, valuePtr);
CACHE_STACK_INFO();
- goto checkForCatch;
- } else {
- /* ... TryConvertToNumeric($NonNumeric) is acceptable */
- TRACE(("\"%.20s\" => not numeric\n", O2S(valuePtr)));
- NEXT_INST_F(1, 0, 0);
+ goto gotError;
}
+
+ /* ... TryConvertToNumeric($NonNumeric) is acceptable */
+ TRACE(("\"%.20s\" => not numeric\n", O2S(valuePtr)));
+ 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.
@@ -6493,12 +5952,11 @@ TclExecuteByteCode(
TRACE(("\"%.20s\" => IEEE FLOATING PT ERROR\n",
O2S(objResultPtr)));
DECACHE_STACK_INFO();
- TclExprFloatError(interp, *((const double *)ptr));
+ 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
@@ -6533,6 +5991,11 @@ TclExecuteByteCode(
NEXT_INST_F(1, 0, 0);
}
+ /*
+ * End of numeric operator instructions.
+ * -----------------------------------------------------------------
+ */
+
case INST_BREAK:
/*
DECACHE_STACK_INFO();
@@ -6553,21 +6016,25 @@ TclExecuteByteCode(
cleanup = 0;
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:
/*
* Initialize the temporary local var that holds the count of the
* number of iterations of the loop body to -1.
*/
- int opnd, iterTmpIndex;
- ForeachInfo *infoPtr;
- Var *iterVarPtr;
- Tcl_Obj *oldValuePtr;
-
opnd = TclGetUInt4AtPtr(pc+1);
- infoPtr = (ForeachInfo *) codePtr->auxDataArrayPtr[opnd].clientData;
+ infoPtr = codePtr->auxDataArrayPtr[opnd].clientData;
iterTmpIndex = infoPtr->loopCtTemp;
- iterVarPtr = &(compiledLocals[iterTmpIndex]);
+ iterVarPtr = LOCAL(iterTmpIndex);
oldValuePtr = iterVarPtr->value.objPtr;
if (oldValuePtr == NULL) {
@@ -6590,33 +6057,24 @@ TclExecuteByteCode(
#else
NEXT_INST_F(5, 0, 0);
#endif
- }
- case INST_FOREACH_STEP4: {
+ case INST_FOREACH_STEP4:
/*
* "Step" a foreach loop (i.e., begin its next iteration) by assigning
* the next value list element to each loop var.
*/
- ForeachInfo *infoPtr;
- ForeachVarList *varListPtr;
- Tcl_Obj *listPtr,*valuePtr, *value2Ptr, **elements;
- Var *iterVarPtr, *listVarPtr, *varPtr;
- int opnd, numLists, iterNum, listTmpIndex, listLen, numVars;
- int varIndex, valIndex, continueLoop, j;
- long i;
-
opnd = TclGetUInt4AtPtr(pc+1);
- infoPtr = (ForeachInfo *) codePtr->auxDataArrayPtr[opnd].clientData;
+ 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);
/*
@@ -6630,19 +6088,17 @@ TclExecuteByteCode(
varListPtr = infoPtr->varLists[i];
numVars = varListPtr->numVars;
- listVarPtr = &(compiledLocals[listTmpIndex]);
+ listVarPtr = LOCAL(listTmpIndex);
listPtr = listVarPtr->value.objPtr;
- result = TclListObjLength(interp, listPtr, &listLen);
- if (result == TCL_OK) {
- if (listLen > (iterNum * numVars)) {
- continueLoop = 1;
- }
- listTmpIndex++;
- } else {
+ if (TclListObjLength(interp, listPtr, &listLen) != TCL_OK) {
TRACE_WITH_OBJ(("%u => ERROR converting list %ld, \"%s\": ",
opnd, i, O2S(listPtr)), Tcl_GetObjResult(interp));
- goto checkForCatch;
+ goto gotError;
+ }
+ if (listLen > iterNum * numVars) {
+ continueLoop = 1;
}
+ listTmpIndex++;
}
/*
@@ -6660,7 +6116,7 @@ TclExecuteByteCode(
varListPtr = infoPtr->varLists[i];
numVars = varListPtr->numVars;
- listVarPtr = &(compiledLocals[listTmpIndex]);
+ listVarPtr = LOCAL(listTmpIndex);
listPtr = TclListObjCopy(NULL, listVarPtr->value.objPtr);
TclListObjGetElements(interp, listPtr, &listLen, &elements);
@@ -6673,7 +6129,7 @@ TclExecuteByteCode(
}
varIndex = varListPtr->varIndexes[j];
- varPtr = &(compiledLocals[varIndex]);
+ varPtr = LOCAL(varIndex);
while (TclIsVarLink(varPtr)) {
varPtr = varPtr->value.linkPtr;
}
@@ -6688,17 +6144,16 @@ TclExecuteByteCode(
}
} else {
DECACHE_STACK_INFO();
- value2Ptr = TclPtrSetVar(interp, varPtr, NULL, NULL,
- NULL, valuePtr, TCL_LEAVE_ERR_MSG, varIndex);
- CACHE_STACK_INFO();
- if (value2Ptr == NULL) {
+ if (TclPtrSetVar(interp, varPtr, NULL, NULL, NULL,
+ valuePtr, TCL_LEAVE_ERR_MSG, varIndex)==NULL){
+ CACHE_STACK_INFO();
TRACE_WITH_OBJ((
"%u => ERROR init. index temp %d: ",
opnd,varIndex), Tcl_GetObjResult(interp));
- result = TCL_ERROR;
TclDecrRefCount(listPtr);
- goto checkForCatch;
+ goto gotError;
}
+ CACHE_STACK_INFO();
}
valIndex++;
}
@@ -6752,14 +6207,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:
@@ -6768,51 +6219,106 @@ 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;
+ }
+ NEXT_INST_F(2*code -1, 1, 0);
+ }
+
+ /*
+ * -----------------------------------------------------------------
+ * Start of dictionary-related instructions.
+ */
+
{
- int opnd, opnd2, allocateDict;
- Tcl_Obj *dictPtr, *valPtr;
- Var *varPtr;
+ 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(("=> "));
+ if (Tcl_DictObjSize(interp, dictPtr, &done) != TCL_OK) {
+ TRACE_APPEND(("ERROR verifying dictionary nature of \"%s\": %s\n",
+ O2S(OBJ_AT_DEPTH(opnd)), 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;
+
opnd = TclGetUInt4AtPtr(pc+1);
TRACE(("%u => ", opnd));
dictPtr = OBJ_AT_DEPTH(opnd);
+ if (*pc == INST_DICT_EXISTS) {
+ interp2 = NULL;
+ }
if (opnd > 1) {
- dictPtr = TclTraceDictPath(interp, dictPtr, opnd-1,
+ dictPtr = TclTraceDictPath(interp2, dictPtr, opnd-1,
&OBJ_AT_DEPTH(opnd-1), DICT_PATH_READ);
if (dictPtr == NULL) {
+ if (*pc == INST_DICT_EXISTS) {
+ goto dictNotExists;
+ }
TRACE_WITH_OBJ((
- "%u => ERROR tracing dictionary path into \"%s\": ",
- opnd, O2S(OBJ_AT_DEPTH(opnd))),
+ "ERROR tracing dictionary path into \"%s\": ",
+ O2S(OBJ_AT_DEPTH(opnd))),
Tcl_GetObjResult(interp));
- result = TCL_ERROR;
- goto checkForCatch;
+ goto gotError;
}
}
- result = Tcl_DictObjGet(interp, dictPtr, OBJ_AT_TOS, &objResultPtr);
- if ((result == TCL_OK) && objResultPtr) {
- TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
- NEXT_INST_V(5, opnd+1, 1);
- }
- if (result != TCL_OK) {
- TRACE_WITH_OBJ((
- "%u => ERROR reading leaf dictionary key \"%s\": ",
- opnd, O2S(dictPtr)), Tcl_GetObjResult(interp));
- } else {
+ if (Tcl_DictObjGet(interp2, dictPtr, OBJ_AT_TOS,
+ &objResultPtr) == TCL_OK) {
+ if (*pc == INST_DICT_EXISTS) {
+ objResultPtr = TCONST(objResultPtr ? 1 : 0);
+ TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
+ NEXT_INST_V(5, opnd+1, 1);
+ }
+ if (objResultPtr) {
+ TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
+ NEXT_INST_V(5, opnd+1, 1);
+ }
DECACHE_STACK_INFO();
- Tcl_ResetResult(interp);
- Tcl_AppendResult(interp, "key \"", TclGetString(OBJ_AT_TOS),
- "\" not known in dictionary", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "key \"%s\" not known in dictionary",
+ TclGetString(OBJ_AT_TOS)));
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "DICT",
+ TclGetString(OBJ_AT_TOS), NULL);
CACHE_STACK_INFO();
TRACE_WITH_OBJ(("%u => ERROR ", opnd), Tcl_GetObjResult(interp));
- result = TCL_ERROR;
+ } else {
+ if (*pc == INST_DICT_EXISTS) {
+ dictNotExists:
+ objResultPtr = TCONST(0);
+ TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
+ NEXT_INST_V(5, opnd+1, 1);
+ }
+ TRACE_WITH_OBJ((
+ "%u => ERROR reading leaf dictionary key \"%s\": ",
+ opnd, O2S(dictPtr)), Tcl_GetObjResult(interp));
}
- goto checkForCatch;
+ goto gotError;
+ }
case INST_DICT_SET:
case INST_DICT_UNSET:
@@ -6820,7 +6326,7 @@ TclExecuteByteCode(
opnd = TclGetUInt4AtPtr(pc+1);
opnd2 = TclGetUInt4AtPtr(pc+5);
- varPtr = &(compiledLocals[opnd2]);
+ varPtr = LOCAL(opnd2);
while (TclIsVarLink(varPtr)) {
varPtr = varPtr->value.linkPtr;
}
@@ -6851,25 +6357,24 @@ TclExecuteByteCode(
case INST_DICT_INCR_IMM:
cleanup = 1;
opnd = TclGetInt4AtPtr(pc+1);
- result = Tcl_DictObjGet(interp, dictPtr, OBJ_AT_TOS, &valPtr);
+ result = Tcl_DictObjGet(interp, dictPtr, OBJ_AT_TOS, &valuePtr);
if (result != TCL_OK) {
break;
}
- if (valPtr == NULL) {
+ 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, OBJ_AT_TOS, 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) {
TclInvalidateStringRep(dictPtr);
}
- TclDecrRefCount(incrPtr);
+ TclDecrRefCount(value2Ptr);
}
break;
case INST_DICT_UNSET:
@@ -6893,11 +6398,10 @@ TclExecuteByteCode(
if (TclIsVarDirectWritable(varPtr)) {
if (allocateDict) {
- Tcl_Obj *oldValuePtr = varPtr->value.objPtr;
-
+ value2Ptr = varPtr->value.objPtr;
Tcl_IncrRefCount(dictPtr);
- if (oldValuePtr != NULL) {
- TclDecrRefCount(oldValuePtr);
+ if (value2Ptr != NULL) {
+ TclDecrRefCount(value2Ptr);
}
varPtr->value.objPtr = dictPtr;
}
@@ -6912,8 +6416,7 @@ TclExecuteByteCode(
if (objResultPtr == NULL) {
TRACE_APPEND(("ERROR: %.30s\n",
O2S(Tcl_GetObjResult(interp))));
- result = TCL_ERROR;
- goto checkForCatch;
+ goto gotError;
}
}
#ifndef TCL_COMPILE_DEBUG
@@ -6927,8 +6430,7 @@ TclExecuteByteCode(
case INST_DICT_APPEND:
case INST_DICT_LAPPEND:
opnd = TclGetUInt4AtPtr(pc+1);
-
- varPtr = &(compiledLocals[opnd]);
+ varPtr = LOCAL(opnd);
while (TclIsVarLink(varPtr)) {
varPtr = varPtr->value.linkPtr;
}
@@ -6950,29 +6452,40 @@ TclExecuteByteCode(
}
}
- result = Tcl_DictObjGet(interp, dictPtr, OBJ_UNDER_TOS, &valPtr);
- if (result != TCL_OK) {
+ if (Tcl_DictObjGet(interp, dictPtr, OBJ_UNDER_TOS,
+ &valuePtr) != TCL_OK) {
if (allocateDict) {
TclDecrRefCount(dictPtr);
}
- goto checkForCatch;
+ 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 = OBJ_AT_TOS;
+ 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, OBJ_AT_TOS);
+ 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:
@@ -6980,41 +6493,51 @@ TclExecuteByteCode(
* More complex because list-append can fail.
*/
- if (valPtr == NULL) {
- valPtr = Tcl_NewListObj(1, &OBJ_AT_TOS);
- } else if (Tcl_IsShared(valPtr)) {
- valPtr = Tcl_DuplicateObj(valPtr);
- result = Tcl_ListObjAppendElement(interp, valPtr, OBJ_AT_TOS);
- if (result != TCL_OK) {
- TclDecrRefCount(valPtr);
+ if (valuePtr == NULL) {
+ Tcl_DictObjPut(NULL, dictPtr, OBJ_UNDER_TOS,
+ Tcl_NewListObj(1, &OBJ_AT_TOS));
+ break;
+ } else if (Tcl_IsShared(valuePtr)) {
+ valuePtr = Tcl_DuplicateObj(valuePtr);
+ if (Tcl_ListObjAppendElement(interp, valuePtr,
+ OBJ_AT_TOS) != TCL_OK) {
+ TclDecrRefCount(valuePtr);
if (allocateDict) {
TclDecrRefCount(dictPtr);
}
- goto checkForCatch;
+ goto gotError;
}
+ Tcl_DictObjPut(NULL, dictPtr, OBJ_UNDER_TOS, valuePtr);
} else {
- result = Tcl_ListObjAppendElement(interp, valPtr, OBJ_AT_TOS);
- if (result != TCL_OK) {
+ if (Tcl_ListObjAppendElement(interp, valuePtr,
+ OBJ_AT_TOS) != TCL_OK) {
if (allocateDict) {
TclDecrRefCount(dictPtr);
}
- goto checkForCatch;
+ 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, OBJ_UNDER_TOS, valPtr);
-
if (TclIsVarDirectWritable(varPtr)) {
if (allocateDict) {
- Tcl_Obj *oldValuePtr = varPtr->value.objPtr;
-
+ value2Ptr = varPtr->value.objPtr;
Tcl_IncrRefCount(dictPtr);
- if (oldValuePtr != NULL) {
- TclDecrRefCount(oldValuePtr);
+ if (value2Ptr != NULL) {
+ TclDecrRefCount(value2Ptr);
}
varPtr->value.objPtr = dictPtr;
}
@@ -7029,8 +6552,7 @@ TclExecuteByteCode(
if (objResultPtr == NULL) {
TRACE_APPEND(("ERROR: %.30s\n",
O2S(Tcl_GetObjResult(interp))));
- result = TCL_ERROR;
- goto checkForCatch;
+ goto gotError;
}
}
#ifndef TCL_COMPILE_DEBUG
@@ -7040,36 +6562,27 @@ 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);
- goto checkForCatch;
+ searchPtr = ckalloc(sizeof(Tcl_DictSearch));
+ if (Tcl_DictObjFirst(interp, dictPtr, searchPtr, &keyPtr,
+ &valuePtr, &done) != TCL_OK) {
+ ckfree(searchPtr);
+ goto gotError;
}
TclNewObj(statePtr);
statePtr->typePtr = &dictIteratorType;
- statePtr->internalRep.twoPtrValue.ptr1 = (void *) searchPtr;
- statePtr->internalRep.twoPtrValue.ptr2 = (void *) dictPtr;
- varPtr = (compiledLocals + opnd);
+ statePtr->internalRep.twoPtrValue.ptr1 = searchPtr;
+ statePtr->internalRep.twoPtrValue.ptr2 = dictPtr;
+ varPtr = LOCAL(opnd);
if (varPtr->value.objPtr) {
- if (varPtr->value.objPtr->typePtr != &dictIteratorType) {
- TclDecrRefCount(varPtr->value.objPtr);
- } else {
+ if (varPtr->value.objPtr->typePtr == &dictIteratorType) {
Tcl_Panic("mis-issued dictFirst!");
}
+ TclDecrRefCount(varPtr->value.objPtr);
}
varPtr->value.objPtr = statePtr;
Tcl_IncrRefCount(statePtr);
@@ -7078,11 +6591,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) {
@@ -7093,62 +6606,46 @@ TclExecuteByteCode(
PUSH_OBJECT(valuePtr);
PUSH_OBJECT(keyPtr);
}
- TRACE_APPEND(("\"%.30s\" \"%.30s\" %d",
- O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS), done));
- objResultPtr = constants[done];
- /* TODO: consider opt like INST_FOREACH_STEP4 */
- NEXT_INST_F(5, 0, 1);
-
- 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;
- TclDecrRefCount(dictPtr);
-
- /*
- * Set the internal variable to an empty object to signify that we
- * don't hold an iterator.
- */
+#ifndef TCL_COMPILE_DEBUG
+ /*
+ * The INST_DICT_FIRST and INST_DICT_NEXT instructsions are always
+ * followed by a conditional jump, so we can take advantage of this to
+ * do some peephole optimization (note that we're careful to not close
+ * out someone doing something else).
+ */
- TclDecrRefCount(statePtr);
- TclNewObj(emptyPtr);
- compiledLocals[opnd].value.objPtr = emptyPtr;
- Tcl_IncrRefCount(emptyPtr);
+ pc += 5;
+ switch (*pc) {
+ case INST_JUMP_FALSE1:
+ NEXT_INST_F((done ? 2 : TclGetInt1AtPtr(pc+1)), 0, 0);
+ case INST_JUMP_FALSE4:
+ NEXT_INST_F((done ? 5 : TclGetInt4AtPtr(pc+1)), 0, 0);
+ case INST_JUMP_TRUE1:
+ NEXT_INST_F((done ? TclGetInt1AtPtr(pc+1) : 2), 0, 0);
+ case INST_JUMP_TRUE4:
+ NEXT_INST_F((done ? TclGetInt4AtPtr(pc+1) : 5), 0, 0);
+ default:
+ pc -= 5;
+ /* fall through to non-debug handling */
}
- NEXT_INST_F(5, 0, 0);
- }
+#endif
- {
- int opnd, opnd2, i, length, allocdict;
- Tcl_Obj **keyPtrPtr, *dictPtr;
- DictUpdateInfo *duiPtr;
- Var *varPtr;
+ TRACE_APPEND(("\"%.30s\" \"%.30s\" %d\n",
+ O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS), done));
+ objResultPtr = TCONST(done);
+ /* TODO: consider opt like INST_FOREACH_STEP4 */
+ NEXT_INST_F(5, 0, 1);
case INST_DICT_UPDATE_START:
opnd = TclGetUInt4AtPtr(pc+1);
opnd2 = TclGetUInt4AtPtr(pc+5);
- varPtr = &(compiledLocals[opnd]);
+ varPtr = LOCAL(opnd);
duiPtr = codePtr->auxDataArrayPtr[opnd2].clientData;
while (TclIsVarLink(varPtr)) {
varPtr = varPtr->value.linkPtr;
}
- TRACE(("%u => ", opnd));
+ TRACE(("%u => \n", opnd));
if (TclIsVarDirectReadable(varPtr)) {
dictPtr = varPtr->value.objPtr;
} else {
@@ -7157,39 +6654,35 @@ TclExecuteByteCode(
TCL_LEAVE_ERR_MSG, opnd);
CACHE_STACK_INFO();
if (dictPtr == NULL) {
- goto dictUpdateStartFailed;
+ goto gotError;
}
}
if (TclListObjGetElements(interp, OBJ_AT_TOS, &length,
&keyPtrPtr) != TCL_OK) {
- goto dictUpdateStartFailed;
+ goto gotError;
}
if (length != duiPtr->length) {
Tcl_Panic("dictUpdateStart argument length mismatch");
}
for (i=0 ; i<length ; i++) {
- Tcl_Obj *valPtr;
-
if (Tcl_DictObjGet(interp, dictPtr, keyPtrPtr[i],
- &valPtr) != TCL_OK) {
- goto dictUpdateStartFailed;
+ &valuePtr) != TCL_OK) {
+ goto gotError;
}
- varPtr = &(compiledLocals[duiPtr->varIndices[i]]);
+ varPtr = LOCAL(duiPtr->varIndices[i]);
while (TclIsVarLink(varPtr)) {
varPtr = varPtr->value.linkPtr;
}
DECACHE_STACK_INFO();
- if (valPtr == NULL) {
+ if (valuePtr == NULL) {
TclObjUnsetVar2(interp,
localName(iPtr->varFramePtr, duiPtr->varIndices[i]),
NULL, 0);
} else if (TclPtrSetVar(interp, varPtr, NULL, NULL, NULL,
- valPtr, TCL_LEAVE_ERR_MSG,
+ valuePtr, TCL_LEAVE_ERR_MSG,
duiPtr->varIndices[i]) == NULL) {
CACHE_STACK_INFO();
- dictUpdateStartFailed:
- result = TCL_ERROR;
- goto checkForCatch;
+ goto gotError;
}
CACHE_STACK_INFO();
}
@@ -7198,7 +6691,7 @@ TclExecuteByteCode(
case INST_DICT_UPDATE_END:
opnd = TclGetUInt4AtPtr(pc+1);
opnd2 = TclGetUInt4AtPtr(pc+5);
- varPtr = &(compiledLocals[opnd]);
+ varPtr = LOCAL(opnd);
duiPtr = codePtr->auxDataArrayPtr[opnd2].clientData;
while (TclIsVarLink(varPtr)) {
varPtr = varPtr->value.linkPtr;
@@ -7217,36 +6710,36 @@ TclExecuteByteCode(
if (Tcl_DictObjSize(interp, dictPtr, &length) != TCL_OK
|| TclListObjGetElements(interp, OBJ_AT_TOS, &length,
&keyPtrPtr) != TCL_OK) {
- result = TCL_ERROR;
- goto checkForCatch;
+ 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;
- Var *var2Ptr;
+ Var *var2Ptr = LOCAL(duiPtr->varIndices[i]);
- var2Ptr = &(compiledLocals[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, NULL, 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 == valPtr) {
+ } else if (dictPtr == valuePtr) {
Tcl_DictObjPut(interp, dictPtr, keyPtrPtr[i],
- Tcl_DuplicateObj(valPtr));
+ Tcl_DuplicateObj(valuePtr));
} else {
- Tcl_DictObjPut(interp, dictPtr, keyPtrPtr[i], valPtr);
+ Tcl_DictObjPut(interp, dictPtr, keyPtrPtr[i], valuePtr);
}
}
if (TclIsVarDirectWritable(varPtr)) {
@@ -7262,45 +6755,93 @@ TclExecuteByteCode(
if (allocdict) {
TclDecrRefCount(dictPtr);
}
- result = TCL_ERROR;
- goto checkForCatch;
+ goto gotError;
}
}
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;
+ if (TclListObjGetElements(interp, listPtr, &objc, &objv) != TCL_OK) {
+ TRACE_WITH_OBJ(("%.30s %.30s => ERROR: ",
+ O2S(dictPtr), O2S(listPtr)), Tcl_GetObjResult(interp));
+ goto gotError;
+ }
+ objResultPtr = TclDictWithInit(interp, dictPtr, objc, objv);
+ if (objResultPtr == NULL) {
+ TRACE_WITH_OBJ(("%.30s %.30s => ERROR: ",
+ O2S(dictPtr), O2S(listPtr)), Tcl_GetObjResult(interp));
+ goto gotError;
+ }
+ TRACE((" => "));
+ TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
+ NEXT_INST_F(1, 2, 1);
- divideByZero:
- DECACHE_STACK_INFO();
- Tcl_SetObjResult(interp, Tcl_NewStringObj("divide by zero", -1));
- Tcl_SetErrorCode(interp, "ARITH", "DIVZERO", "divide by zero", NULL);
- CACHE_STACK_INFO();
+ case INST_DICT_RECOMBINE_STK:
+ keysPtr = POP_OBJECT();
+ varNamePtr = OBJ_UNDER_TOS;
+ listPtr = OBJ_AT_TOS;
+ TRACE(("\"%.30s\" \"%.30s\" \"%.30s\" => ",
+ O2S(varNamePtr), O2S(valuePtr), O2S(keysPtr)));
+ if (TclListObjGetElements(interp, listPtr, &objc, &objv) != TCL_OK) {
+ TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));
+ TclDecrRefCount(keysPtr);
+ goto gotError;
+ }
+ varPtr = TclObjLookupVarEx(interp, varNamePtr, NULL,
+ TCL_LEAVE_ERR_MSG, "set", 1, 1, &arrayPtr);
+ if (varPtr == NULL) {
+ TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));
+ TclDecrRefCount(keysPtr);
+ goto gotError;
+ }
+ DECACHE_STACK_INFO();
+ result = TclDictWithFinish(interp, varPtr,arrayPtr,varNamePtr,NULL,-1,
+ objc, objv, keysPtr);
+ CACHE_STACK_INFO();
+ TclDecrRefCount(keysPtr);
+ if (result != TCL_OK) {
+ TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));
+ goto gotError;
+ }
+ TRACE_APPEND(("OK\n"));
+ NEXT_INST_F(1, 2, 0);
- 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_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));
+ goto gotError;
+ }
+ while (TclIsVarLink(varPtr)) {
+ varPtr = varPtr->value.linkPtr;
+ }
+ DECACHE_STACK_INFO();
+ result = TclDictWithFinish(interp, varPtr, NULL, NULL, NULL, opnd,
+ objc, objv, keysPtr);
+ CACHE_STACK_INFO();
+ if (result != TCL_OK) {
+ TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));
+ goto gotError;
+ }
+ TRACE_APPEND(("OK\n"));
+ NEXT_INST_F(5, 2, 0);
+ }
/*
- * Exponentiation of zero by negative number in an expression. Control
- * only reaches this point by "goto exponOfZero".
+ * End of dictionary-related instructions.
+ * -----------------------------------------------------------------
*/
- exponOfZero:
- DECACHE_STACK_INFO();
- Tcl_SetObjResult(interp, Tcl_NewStringObj(
- "exponentiation of zero by negative power", -1));
- Tcl_SetErrorCode(interp, "ARITH", "DOMAIN",
- "exponentiation of zero by negative power", NULL);
- CACHE_STACK_INFO();
- result = TCL_ERROR;
- goto checkForCatch;
+ default:
+ Tcl_Panic("TclNRExecuteByteCode: unrecognized opCode %u", *pc);
+ } /* end of switch on opCode */
/*
* Block for variables needed to process exception returns.
@@ -7312,12 +6853,7 @@ TclExecuteByteCode(
* range enclosing the pc. Used by various
* instructions and processCatch to process
* break, continue, and errors. */
- Tcl_Obj *valuePtr;
const char *bytes;
- int length;
-#if TCL_COMPILE_DEBUG
- int opnd;
-#endif
/*
* An external evaluation (INST_INVOKE or INST_EVAL) returned
@@ -7326,7 +6862,7 @@ TclExecuteByteCode(
*/
processExceptionReturn:
-#if TCL_COMPILE_DEBUG
+#ifdef TCL_COMPILE_DEBUG
switch (*pc) {
case INST_INVOKE_STK1:
opnd = TclGetUInt1AtPtr(pc+1);
@@ -7370,33 +6906,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 (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)) {
- Tcl_Obj *objPtr = Tcl_GetObjResult(interp);
TRACE_APPEND(("OTHER RETURN CODE %d, result= \"%s\"\n ",
result, O2S(objPtr)));
} else {
- Tcl_Obj *objPtr = Tcl_GetObjResult(interp);
TRACE_APPEND(("%s, result= \"%s\"\n",
StringForResultCode(result), O2S(objPtr)));
}
-#endif
}
+#endif
+ goto checkForCatch;
+
+ /*
+ * Division by zero in an expression. Control only reaches this point
+ * by "goto divideByZero".
+ */
+
+ divideByZero:
+ DECACHE_STACK_INFO();
+ Tcl_SetObjResult(interp, Tcl_NewStringObj("divide by zero", -1));
+ Tcl_SetErrorCode(interp, "ARITH", "DIVZERO", "divide by zero", NULL);
+ CACHE_STACK_INFO();
+ goto gotError;
+
+ /*
+ * Exponentiation of zero by negative number in an expression. Control
+ * only reaches this point by "goto exponOfZero".
+ */
+
+ exponOfZero:
+ DECACHE_STACK_INFO();
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "exponentiation of zero by negative power", -1));
+ Tcl_SetErrorCode(interp, "ARITH", "DOMAIN",
+ "exponentiation of zero by negative power", NULL);
+ CACHE_STACK_INFO();
+
+ /*
+ * 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
@@ -7406,14 +6974,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) {
- DECACHE_STACK_INFO();
- Tcl_LogCommandInfo(interp, codePtr->source, bytes, length);
- CACHE_STACK_INFO();
- }
+ 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;
@@ -7422,13 +6994,32 @@ TclExecuteByteCode(
* INST_BEGIN_CATCH.
*/
- while ((expandNestList != NULL) && ((catchTop == initCatchTop) ||
- (*catchTop <=
- (ptrdiff_t) expandNestList->internalRep.twoPtrValue.ptr1))) {
- Tcl_Obj *objPtr = expandNestList->internalRep.twoPtrValue.ptr2;
+ while (auxObjList) {
+ if ((catchTop != initCatchTop)
+ && (*catchTop > (ptrdiff_t)
+ auxObjList->internalRep.ptrAndLongRep.value)) {
+ break;
+ }
+ POP_TAUX_OBJ();
+ }
+
+ /*
+ * We must not catch if the script in progress has been canceled with
+ * the TCL_CANCEL_UNWIND flag. Instead, it blows outwards until we
+ * either hit another interpreter (presumably where the script in
+ * progress has not been canceled) or we get to the top-level. We do
+ * NOT modify the interpreter result here because we know it will
+ * already be set prior to vectoring down to this point in the code.
+ */
- TclDecrRefCount(expandNestList);
- expandNestList = objPtr;
+ 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;
}
/*
@@ -7460,7 +7051,7 @@ 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
@@ -7508,39 +7099,1445 @@ TclExecuteByteCode(
abnormalReturn:
TCL_DTRACE_INST_LAST();
- while (tosPtr > initTosPtr) {
- Tcl_Obj *objPtr = POP_OBJECT();
-
- Tcl_DecrRefCount(objPtr);
- }
/*
- * Clear all expansions.
+ * Clear all expansions and same-level NR calls.
+ *
+ * Note that expansion markers have a NULL type; avoid removing other
+ * markers.
*/
- while (expandNestList) {
- Tcl_Obj *objPtr = expandNestList->internalRep.twoPtrValue.ptr2;
-
- TclDecrRefCount(expandNestList);
- expandNestList = objPtr;
+ while (auxObjList) {
+ POP_TAUX_OBJ();
}
+ while (tosPtr > initTosPtr) {
+ objPtr = POP_OBJECT();
+ Tcl_DecrRefCount(objPtr);
+ }
+
if (tosPtr < initTosPtr) {
fprintf(stderr,
- "\nTclExecuteByteCode: abnormal return at pc %u: "
+ "\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("TclExecuteByteCode execution failure: end stack top < start stack top");
+ 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;
/*
- * Restore the stack to the state it had previous to this bytecode.
+ * 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:
*/
- TclStackFree(interp, initCatchTop+1);
- return result;
+ instStartCmdFailed:
+ {
+ 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
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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)) {
+ /*
+ * Convert to Tcl's integer division rules.
+ */
+
+ mp_sub_d(&bigResult, 1, &bigResult);
+ mp_add(&bigRemainder, &big2, &bigRemainder);
+ }
+ mp_copy(&bigRemainder, &bigResult);
+ mp_clear(&bigRemainder);
+ mp_clear(&big1);
+ mp_clear(&big2);
+ BIG_RESULT(&bigResult);
+
+ case INST_LSHIFT:
+ case INST_RSHIFT: {
+ /*
+ * Reject negative shift argument.
+ */
+
+ switch (type2) {
+ case TCL_NUMBER_LONG:
+ invalid = (*((const long *)ptr2) < 0L);
+ break;
+#ifndef 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);
+ }
+ 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);
+ }
+#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;
+ }
}
#ifdef TCL_COMPILE_DEBUG
@@ -7550,7 +8547,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:
@@ -7611,7 +8608,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.
*
@@ -7630,16 +8627,15 @@ 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 relativePc = (unsigned) (pc - codePtr->codeStart);
unsigned long codeStart = (unsigned long) codePtr->codeStart;
@@ -7648,22 +8644,22 @@ ValidatePcAndStackTop(
unsigned char opCode = *pc;
if (((unsigned long) pc < codeStart) || ((unsigned long) pc > codeEnd)) {
- fprintf(stderr, "\nBad instruction pc 0x%p in TclExecuteByteCode\n",
+ fprintf(stderr, "\nBad instruction pc 0x%p in TclNRExecuteByteCode\n",
pc);
- Tcl_Panic("TclExecuteByteCode execution failure: bad pc");
+ Tcl_Panic("TclNRExecuteByteCode execution failure: bad pc");
}
if ((unsigned) opCode > LAST_INST_OPCODE) {
- fprintf(stderr, "\nBad opcode %d at pc %u in TclExecuteByteCode\n",
+ fprintf(stderr, "\nBad opcode %d at pc %u in TclNRExecuteByteCode\n",
(unsigned) opCode, relativePc);
- Tcl_Panic("TclExecuteByteCode execution failure: bad opcode");
+ Tcl_Panic("TclNRExecuteByteCode execution failure: bad opcode");
}
- if (checkStack &&
- ((stackTop < stackLowerBound) || (stackTop > stackUpperBound))) {
+ if (checkStack &&
+ ((stackTop < 0) || (stackTop > stackUpperBound))) {
int numChars;
- const 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;
@@ -7675,7 +8671,7 @@ ValidatePcAndStackTop(
} else {
fprintf(stderr, "\n");
}
- Tcl_Panic("TclExecuteByteCode execution failure: bad stack top");
+ Tcl_Panic("TclNRExecuteByteCode execution failure: bad stack top");
}
}
#endif /* TCL_COMPILE_DEBUG */
@@ -7685,7 +8681,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.
*
@@ -7702,14 +8698,14 @@ 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 unsigned char opcode = *pc;
const char *description, *operator = operatorStrings[opcode - INST_LOR];
if (opcode == INST_EXPON) {
@@ -7744,7 +8740,7 @@ IllegalExprOperandType(
/*
*----------------------------------------------------------------------
*
- * TclGetSrcInfoForPc, GetSrcInfoForPc, TclGetSrcInfoForCmd --
+ * TclGetSrcInfoForPc, GetSrcInfoForPc, TclGetSourceFromFrame --
*
* Given a program counter value, finds the closest command in the
* bytecode code unit's CmdLocation array and returns information about
@@ -7765,16 +8761,26 @@ IllegalExprOperandType(
*----------------------------------------------------------------------
*/
-const char *
-TclGetSrcInfoForCmd(
- Interp *iPtr,
- int *lenPtr)
+Tcl_Obj *
+TclGetSourceFromFrame(
+ CmdFrame *cfPtr,
+ int objc,
+ Tcl_Obj *const objv[])
{
- CmdFrame *cfPtr = iPtr->cmdFramePtr;
- ByteCode *codePtr = (ByteCode *) cfPtr->data.tebc.codePtr;
+ if (cfPtr == NULL) {
+ return Tcl_NewListObj(objc, objv);
+ }
+ if (cfPtr->cmdObj == NULL) {
+ if (cfPtr->cmd == NULL) {
+ ByteCode *codePtr = (ByteCode *) cfPtr->data.tebc.codePtr;
- return GetSrcInfoForPc((unsigned char *) cfPtr->data.tebc.pc,
- codePtr, lenPtr);
+ 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
@@ -7783,13 +8789,16 @@ TclGetSrcInfoForPc(
{
ByteCode *codePtr = (ByteCode *) cfPtr->data.tebc.codePtr;
- if (cfPtr->cmd.str.cmd == NULL) {
- cfPtr->cmd.str.cmd = GetSrcInfoForPc(
+ assert(cfPtr->type == TCL_LOCATION_BC);
+
+ if (cfPtr->cmd == NULL) {
+
+ cfPtr->cmd = GetSrcInfoForPc(
(unsigned char *) cfPtr->data.tebc.pc, codePtr,
- &cfPtr->cmd.str.len);
+ &cfPtr->len, NULL, NULL);
}
- if (cfPtr->cmd.str.cmd != 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.
@@ -7800,14 +8809,14 @@ TclGetSrcInfoForPc(
int srcOffset, i;
Interp *iPtr = (Interp *) *codePtr->interpHandle;
Tcl_HashEntry *hePtr =
- Tcl_FindHashEntry(iPtr->lineBCPtr, (char *) codePtr);
+ Tcl_FindHashEntry(iPtr->lineBCPtr, codePtr);
if (!hePtr) {
return;
}
- srcOffset = cfPtr->cmd.str.cmd - codePtr->source;
- eclPtr = (ExtCmdLoc *) Tcl_GetHashValue (hePtr);
+ srcOffset = cfPtr->cmd - codePtr->source;
+ eclPtr = Tcl_GetHashValue(hePtr);
for (i=0; i < eclPtr->nuloc; i++) {
if (eclPtr->loc[i].srcOffset == srcOffset) {
@@ -7837,15 +8846,21 @@ TclGetSrcInfoForPc(
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;
@@ -7855,8 +8870,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;
}
@@ -7921,10 +8938,28 @@ GetSrcInfoForPc(
bestDist = dist;
bestSrcOffset = srcOffset;
bestSrcLength = srcLen;
+ bestCmdIdx = i;
}
}
}
+ if (pcBeg != NULL) {
+ const unsigned char *curr, *prev;
+
+ /*
+ * Walk from beginning of command or BC to pc, by complete
+ * instructions. Stop when crossing pc; keep previous.
+ */
+
+ curr = ((bestDist == INT_MAX) ? codePtr->codeStart : pc - bestDist);
+ prev = curr;
+ while (curr <= pc) {
+ prev = curr;
+ curr += tclInstructionTable[*curr].numBytes;
+ }
+ *pcBeg = prev;
+ }
+
if (bestDist == INT_MAX) {
return NULL;
}
@@ -7932,6 +8967,11 @@ GetSrcInfoForPc(
if (lengthPtr != NULL) {
*lengthPtr = bestSrcLength;
}
+
+ if (cmdIdxPtr != NULL) {
+ *cmdIdxPtr = bestCmdIdx;
+ }
+
return (codePtr->source + bestSrcOffset);
}
@@ -7961,7 +9001,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. */
@@ -8009,7 +9049,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:
@@ -8022,9 +9062,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;
@@ -8194,31 +9234,31 @@ EvalStatsCmd(
Tcl_AppendPrintfToObj(objPtr, "\n----------------------------------------------------------------\n");
Tcl_AppendPrintfToObj(objPtr,
"Compilation and execution statistics for interpreter %#lx\n",
- iPtr);
+ (long int)iPtr);
- Tcl_AppendPrintfToObj(objPtr, "\nNumber ByteCodes executed %ld\n",
+ Tcl_AppendPrintfToObj(objPtr, "\nNumber ByteCodes executed\t%ld\n",
statsPtr->numExecutions);
- Tcl_AppendPrintfToObj(objPtr, "Number ByteCodes compiled %ld\n",
+ Tcl_AppendPrintfToObj(objPtr, "Number ByteCodes compiled\t%ld\n",
statsPtr->numCompilations);
- Tcl_AppendPrintfToObj(objPtr, " Mean executions/compile %.1f\n",
+ Tcl_AppendPrintfToObj(objPtr, " Mean executions/compile\t%.1f\n",
statsPtr->numExecutions / (float)statsPtr->numCompilations);
- Tcl_AppendPrintfToObj(objPtr, "\nInstructions executed %.0f\n",
+ Tcl_AppendPrintfToObj(objPtr, "\nInstructions executed\t\t%.0f\n",
numInstructions);
- Tcl_AppendPrintfToObj(objPtr, " Mean inst/compile %.0f\n",
+ Tcl_AppendPrintfToObj(objPtr, " Mean inst/compile\t\t%.0f\n",
numInstructions / statsPtr->numCompilations);
- Tcl_AppendPrintfToObj(objPtr, " Mean inst/execution %.0f\n",
+ Tcl_AppendPrintfToObj(objPtr, " Mean inst/execution\t\t%.0f\n",
numInstructions / statsPtr->numExecutions);
- Tcl_AppendPrintfToObj(objPtr, "\nTotal ByteCodes %ld\n",
+ Tcl_AppendPrintfToObj(objPtr, "\nTotal ByteCodes\t\t\t%ld\n",
statsPtr->numCompilations);
- Tcl_AppendPrintfToObj(objPtr, " Source bytes %.6g\n",
+ Tcl_AppendPrintfToObj(objPtr, " Source bytes\t\t\t%.6g\n",
statsPtr->totalSrcBytes);
- Tcl_AppendPrintfToObj(objPtr, " Code bytes %.6g\n",
+ Tcl_AppendPrintfToObj(objPtr, " Code bytes\t\t\t%.6g\n",
totalCodeBytes);
- Tcl_AppendPrintfToObj(objPtr, " ByteCode bytes %.6g\n",
+ Tcl_AppendPrintfToObj(objPtr, " ByteCode bytes\t\t%.6g\n",
statsPtr->totalByteCodeBytes);
- Tcl_AppendPrintfToObj(objPtr, " Literal bytes %.6g\n",
+ Tcl_AppendPrintfToObj(objPtr, " Literal bytes\t\t%.6g\n",
totalLiteralBytes);
Tcl_AppendPrintfToObj(objPtr, " table %lu + bkts %lu + entries %lu + objects %lu + strings %.6g\n",
(unsigned long) sizeof(LiteralTable),
@@ -8226,20 +9266,20 @@ EvalStatsCmd(
(unsigned long) (statsPtr->numLiteralsCreated * sizeof(LiteralEntry)),
(unsigned long) (statsPtr->numLiteralsCreated * sizeof(Tcl_Obj)),
statsPtr->totalLitStringBytes);
- Tcl_AppendPrintfToObj(objPtr, " Mean code/compile %.1f\n",
+ Tcl_AppendPrintfToObj(objPtr, " Mean code/compile\t\t%.1f\n",
totalCodeBytes / statsPtr->numCompilations);
- Tcl_AppendPrintfToObj(objPtr, " Mean code/source %.1f\n",
+ Tcl_AppendPrintfToObj(objPtr, " Mean code/source\t\t%.1f\n",
totalCodeBytes / statsPtr->totalSrcBytes);
- Tcl_AppendPrintfToObj(objPtr, "\nCurrent (active) ByteCodes %ld\n",
+ Tcl_AppendPrintfToObj(objPtr, "\nCurrent (active) ByteCodes\t%ld\n",
numCurrentByteCodes);
- Tcl_AppendPrintfToObj(objPtr, " Source bytes %.6g\n",
+ Tcl_AppendPrintfToObj(objPtr, " Source bytes\t\t\t%.6g\n",
statsPtr->currentSrcBytes);
- Tcl_AppendPrintfToObj(objPtr, " Code bytes %.6g\n",
+ Tcl_AppendPrintfToObj(objPtr, " Code bytes\t\t\t%.6g\n",
currentCodeBytes);
- Tcl_AppendPrintfToObj(objPtr, " ByteCode bytes %.6g\n",
+ Tcl_AppendPrintfToObj(objPtr, " ByteCode bytes\t\t%.6g\n",
statsPtr->currentByteCodeBytes);
- Tcl_AppendPrintfToObj(objPtr, " Literal bytes %.6g\n",
+ Tcl_AppendPrintfToObj(objPtr, " Literal bytes\t\t%.6g\n",
currentLiteralBytes);
Tcl_AppendPrintfToObj(objPtr, " table %lu + bkts %lu + entries %lu + objects %lu + strings %.6g\n",
(unsigned long) sizeof(LiteralTable),
@@ -8247,9 +9287,9 @@ EvalStatsCmd(
(unsigned long) (iPtr->literalTable.numEntries * sizeof(LiteralEntry)),
(unsigned long) (iPtr->literalTable.numEntries * sizeof(Tcl_Obj)),
statsPtr->currentLitStringBytes);
- Tcl_AppendPrintfToObj(objPtr, " Mean code/source %.1f\n",
+ Tcl_AppendPrintfToObj(objPtr, " Mean code/source\t\t%.1f\n",
currentCodeBytes / statsPtr->currentSrcBytes);
- Tcl_AppendPrintfToObj(objPtr, " 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);
@@ -8262,17 +9302,17 @@ EvalStatsCmd(
numSharedMultX = 0;
Tcl_AppendPrintfToObj(objPtr, "\nTcl_IsShared object check (all objects):\n");
- Tcl_AppendPrintfToObj(objPtr, " Object had refcount <=1 (not shared) %ld\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++) {
- Tcl_AppendPrintfToObj(objPtr, " refcount ==%d %ld\n",
+ Tcl_AppendPrintfToObj(objPtr, " refcount ==%d\t\t%ld\n",
i, tclObjsShared[i]);
numSharedMultX += tclObjsShared[i];
}
- Tcl_AppendPrintfToObj(objPtr, " refcount >=%d %ld\n",
+ Tcl_AppendPrintfToObj(objPtr, " refcount >=%d\t\t%ld\n",
i, tclObjsShared[0]);
numSharedMultX += tclObjsShared[0];
- Tcl_AppendPrintfToObj(objPtr, " Total shared objects %d\n",
+ Tcl_AppendPrintfToObj(objPtr, " Total shared objects\t\t\t%d\n",
numSharedMultX);
/*
@@ -8309,31 +9349,31 @@ EvalStatsCmd(
sharingBytesSaved = (objBytesIfUnshared + strBytesIfUnshared)
- currentLiteralBytes;
- Tcl_AppendPrintfToObj(objPtr, "\nTotal objects (all interps) %ld\n",
+ Tcl_AppendPrintfToObj(objPtr, "\nTotal objects (all interps)\t%ld\n",
tclObjsAlloced);
- Tcl_AppendPrintfToObj(objPtr, "Current objects %ld\n",
+ Tcl_AppendPrintfToObj(objPtr, "Current objects\t\t\t%ld\n",
(tclObjsAlloced - tclObjsFreed));
- Tcl_AppendPrintfToObj(objPtr, "Total literal objects %ld\n",
+ Tcl_AppendPrintfToObj(objPtr, "Total literal objects\t\t%ld\n",
statsPtr->numLiteralsCreated);
- Tcl_AppendPrintfToObj(objPtr, "\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,
Percent(globalTablePtr->numEntries, tclObjsAlloced-tclObjsFreed));
- Tcl_AppendPrintfToObj(objPtr, " ByteCode literals %ld (%0.1f%% of current literals)\n",
+ Tcl_AppendPrintfToObj(objPtr, " ByteCode literals\t\t%ld (%0.1f%% of current literals)\n",
numByteCodeLits,
Percent(numByteCodeLits, globalTablePtr->numEntries));
- Tcl_AppendPrintfToObj(objPtr, " Literals reused > 1x %d\n",
+ Tcl_AppendPrintfToObj(objPtr, " Literals reused > 1x\t\t%d\n",
numSharedMultX);
- Tcl_AppendPrintfToObj(objPtr, " Mean reference count %.2f\n",
+ Tcl_AppendPrintfToObj(objPtr, " Mean reference count\t\t%.2f\n",
((double) refCountSum) / globalTablePtr->numEntries);
- Tcl_AppendPrintfToObj(objPtr, " Mean len, str reused >1x %.2f\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 %.2f\n",
+ Tcl_AppendPrintfToObj(objPtr, " Mean len, str used 1x\t\t%.2f\n",
(numSharedOnce ? strBytesSharedOnce/numSharedOnce : 0.0));
- Tcl_AppendPrintfToObj(objPtr, " Total sharing savings %.6g (%0.1f%% of bytes if no sharing)\n",
+ Tcl_AppendPrintfToObj(objPtr, " Total sharing savings\t\t%.6g (%0.1f%% of bytes if no sharing)\n",
sharingBytesSaved,
Percent(sharingBytesSaved, objBytesIfUnshared+strBytesIfUnshared));
- Tcl_AppendPrintfToObj(objPtr, " Bytes with sharing %.6g\n",
+ Tcl_AppendPrintfToObj(objPtr, " Bytes with sharing\t\t%.6g\n",
currentLiteralBytes);
Tcl_AppendPrintfToObj(objPtr, " table %lu + bkts %lu + entries %lu + objects %lu + strings %.6g\n",
(unsigned long) sizeof(LiteralTable),
@@ -8341,13 +9381,13 @@ EvalStatsCmd(
(unsigned long) (iPtr->literalTable.numEntries * sizeof(LiteralEntry)),
(unsigned long) (iPtr->literalTable.numEntries * sizeof(Tcl_Obj)),
statsPtr->currentLitStringBytes);
- Tcl_AppendPrintfToObj(objPtr, " Bytes if no sharing %.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);
- Tcl_AppendPrintfToObj(objPtr, " 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);
- Tcl_AppendPrintfToObj(objPtr, " 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,
Percent(literalMgmtBytes, currentLiteralBytes));
Tcl_AppendPrintfToObj(objPtr, " table %lu + buckets %lu + entries %lu\n",
@@ -8395,7 +9435,7 @@ EvalStatsCmd(
*/
Tcl_AppendPrintfToObj(objPtr, "\nLiteral string sizes:\n");
- Tcl_AppendPrintfToObj(objPtr, " Up to length Percentage\n");
+ Tcl_AppendPrintfToObj(objPtr, "\t Up to length\t\tPercentage\n");
maxSizeDecade = 0;
for (i = 31; i >= 0; i--) {
if (statsPtr->literalCount[i] > 0) {
@@ -8407,21 +9447,21 @@ EvalStatsCmd(
for (i = 0; i <= maxSizeDecade; i++) {
decadeHigh = (1 << (i+1)) - 1;
sum += statsPtr->literalCount[i];
- Tcl_AppendPrintfToObj(objPtr, " %10d %8.0f%%\n",
+ Tcl_AppendPrintfToObj(objPtr, "\t%10d\t\t%8.0f%%\n",
decadeHigh, Percent(sum, statsPtr->numLiteralsCreated));
}
litTableStats = TclLiteralStats(globalTablePtr);
Tcl_AppendPrintfToObj(objPtr, "\nCurrent literal table statistics:\n%s\n",
litTableStats);
- ckfree((char *) litTableStats);
+ ckfree(litTableStats);
/*
* Source and ByteCode size distributions.
*/
Tcl_AppendPrintfToObj(objPtr, "\nSource sizes:\n");
- Tcl_AppendPrintfToObj(objPtr, " Up to size Percentage\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) {
@@ -8439,12 +9479,12 @@ EvalStatsCmd(
for (i = minSizeDecade; i <= maxSizeDecade; i++) {
decadeHigh = (1 << (i+1)) - 1;
sum += statsPtr->srcCount[i];
- Tcl_AppendPrintfToObj(objPtr, " %10d %8.0f%%\n",
+ Tcl_AppendPrintfToObj(objPtr, "\t%10d\t\t%8.0f%%\n",
decadeHigh, Percent(sum, statsPtr->numCompilations));
}
Tcl_AppendPrintfToObj(objPtr, "\nByteCode sizes:\n");
- Tcl_AppendPrintfToObj(objPtr, " Up to size Percentage\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) {
@@ -8462,12 +9502,12 @@ EvalStatsCmd(
for (i = minSizeDecade; i <= maxSizeDecade; i++) {
decadeHigh = (1 << (i+1)) - 1;
sum += statsPtr->byteCodeCount[i];
- Tcl_AppendPrintfToObj(objPtr, " %10d %8.0f%%\n",
+ Tcl_AppendPrintfToObj(objPtr, "\t%10d\t\t%8.0f%%\n",
decadeHigh, Percent(sum, statsPtr->numCompilations));
}
Tcl_AppendPrintfToObj(objPtr, "\nByteCode longevity (excludes Current ByteCodes):\n");
- Tcl_AppendPrintfToObj(objPtr, " Up to ms Percentage\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) {
@@ -8485,7 +9525,7 @@ EvalStatsCmd(
for (i = minSizeDecade; i <= maxSizeDecade; i++) {
decadeHigh = (1 << (i+1)) - 1;
sum += statsPtr->lifetimeCount[i];
- Tcl_AppendPrintfToObj(objPtr, " %12.3f %8.0f%%\n",
+ Tcl_AppendPrintfToObj(objPtr, "\t%12.3f\t\t%8.0f%%\n",
decadeHigh/1000.0, Percent(sum, statsPtr->numByteCodesFreed));
}