From ad4fb382c8f0c304d9349c4b2db7aecd8ace54cb Mon Sep 17 00:00:00 2001 From: dkf Date: Wed, 28 Apr 2010 10:50:15 +0000 Subject: * generic/tclInt.h (TclIsVarDirectUnsettable): Corrected flags so that deletion of traces is not optimized out... * generic/tclExecute.c (ExecuteExtendedBinaryMathOp) (TclCompareTwoNumbers,ExecuteExtendedUnaryMathOp,TclExecuteByteCode): [Patch 2981677]: Move the less common arithmetic operations (i.e., exponentiation and operations on non-longs) out of TEBC for a big drop in the overall size of the stack frame for most code. Net effect on speed is minimal (slightly faster overall in tclbench). Also extended the number of places where TRESULT handling is replaced with a jump to dedicated code. --- ChangeLog | 16 +- generic/tclExecute.c | 5673 +++++++++++++++++++++++++------------------------- generic/tclInt.h | 4 +- 3 files changed, 2864 insertions(+), 2829 deletions(-) diff --git a/ChangeLog b/ChangeLog index 73ea47e..4148c5d 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,17 @@ +2010-04-28 Donal K. Fellows + + * generic/tclInt.h (TclIsVarDirectUnsettable): Corrected flags so that + deletion of traces is not optimized out... + + * generic/tclExecute.c (ExecuteExtendedBinaryMathOp) + (TclCompareTwoNumbers,ExecuteExtendedUnaryMathOp,TclExecuteByteCode): + [Patch 2981677]: Move the less common arithmetic operations (i.e., + exponentiation and operations on non-longs) out of TEBC for a big drop + in the overall size of the stack frame for most code. Net effect on + speed is minimal (slightly faster overall in tclbench). Also extended + the number of places where TRESULT handling is replaced with a jump to + dedicated code. + 2010-04-27 Donal K. Fellows * generic/tclExecute.c (TclExecuteByteCode): Rearrange location of an @@ -45,7 +59,7 @@ 2010-04-24 Miguel Sofer * generic/tclBasic.c: Modify api of TclSpliceTailcall() to fix - * generic/tclExecute.c: yieldTo, which had not survived the latest + * generic/tclExecute.c: [yieldTo], which had not survived the latest * generic/tclInt.h: mods to tailcall. Thanks kbk for detecting the problem. diff --git a/generic/tclExecute.c b/generic/tclExecute.c index f59827c..44988ae 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -14,7 +14,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclExecute.c,v 1.479 2010/04/27 14:58:18 dkf Exp $ + * RCS: @(#) $Id: tclExecute.c,v 1.480 2010/04/28 10:50:34 dkf Exp $ */ #include "tclInt.h" @@ -214,7 +214,7 @@ typedef struct BottomData { #define POP_TAUX_OBJ() \ do { \ - Tcl_Obj *tmpPtr = auxObjList; \ + tmpPtr = auxObjList; \ auxObjList = (Tcl_Obj *) tmpPtr->internalRep.twoPtrValue.ptr2; \ Tcl_DecrRefCount(tmpPtr); \ } while (0) @@ -680,6 +680,14 @@ static const Tcl_WideInt Exp64Value[] = { }; static const size_t Exp64ValueSize = sizeof(Exp64Value) / sizeof(Tcl_WideInt); #endif /* (LONG_MAX > 0x7fffffff) || !defined(TCL_WIDE_INT_IS_LONG) */ + +/* + * Markers for ExecuteExtendedBinaryMathOp. + */ + +#define DIVIDED_BY_ZERO ((Tcl_Obj *) -1) +#define EXPONENT_OF_ZERO ((Tcl_Obj *) -2) +#define GENERAL_ARITHMETIC_ERROR ((Tcl_Obj *) -3) /* * Declarations for local procedures to this file: @@ -702,6 +710,13 @@ static ByteCode * CompileExprObj(Tcl_Interp *interp, Tcl_Obj *objPtr); static void DeleteExecStack(ExecStack *esPtr); static void DupExprCodeInternalRep(Tcl_Obj *srcPtr, Tcl_Obj *copyPtr); +MODULE_SCOPE int TclCompareTwoNumbers(Tcl_Obj *valuePtr, + Tcl_Obj *value2Ptr); +static Tcl_Obj * ExecuteExtendedBinaryMathOp(Tcl_Interp *interp, + int opcode, Tcl_Obj **constants, + Tcl_Obj *valuePtr, Tcl_Obj *value2Ptr); +static Tcl_Obj * ExecuteExtendedUnaryMathOp(int opcode, + Tcl_Obj *valuePtr); static void FreeExprCodeInternalRep(Tcl_Obj *objPtr); static ExceptionRange * GetExceptRangeForPc(const unsigned char *pc, int catchOnly, ByteCode *codePtr); @@ -1967,8 +1982,9 @@ TclExecuteByteCode( * NOTE: These are now mostly defined locally where needed. */ - Tcl_Obj *objPtr, *valuePtr, *value2Ptr, *part1Ptr, *part2Ptr; - int opnd, length; + Tcl_Obj *objPtr, *valuePtr, *value2Ptr, *part1Ptr, *part2Ptr, *tmpPtr; + Tcl_Obj **objv; + int opnd, objc, length, pcAdjustment; Var *varPtr, *arrayPtr; #ifdef TCL_COMPILE_DEBUG int traceInstructions = (tclTraceExec == 3); @@ -2178,32 +2194,27 @@ TclExecuteByteCode( */ if ((TAUX.instructionCount++ & ASYNC_CHECK_COUNT_MASK) == 0) { - int localResult; - + DECACHE_STACK_INFO(); if (TclAsyncReady(iPtr)) { - DECACHE_STACK_INFO(); - localResult = Tcl_AsyncInvoke(interp, TRESULT); - CACHE_STACK_INFO(); - if (localResult == TCL_ERROR) { + TRESULT = Tcl_AsyncInvoke(interp, TRESULT); + if (TRESULT == TCL_ERROR) { + CACHE_STACK_INFO(); goto gotError; } } - DECACHE_STACK_INFO(); - localResult = Tcl_Canceled(interp, TCL_LEAVE_ERR_MSG); - CACHE_STACK_INFO(); - if (localResult == TCL_ERROR) { + if (Tcl_Canceled(interp, TCL_LEAVE_ERR_MSG) == TCL_ERROR) { + CACHE_STACK_INFO(); goto gotError; } if (TclLimitReady(iPtr->limit)) { - DECACHE_STACK_INFO(); - localResult = Tcl_LimitCheck(interp); - CACHE_STACK_INFO(); - if (localResult == TCL_ERROR) { + if (Tcl_LimitCheck(interp) == TCL_ERROR) { + CACHE_STACK_INFO(); goto gotError; } } + CACHE_STACK_INFO(); } TCL_DTRACE_INST_NEXT(); @@ -2239,14 +2250,13 @@ TclExecuteByteCode( TRACE_APPEND(("continuing to next instruction (TRESULT=\"%.30s\")", O2S(objResultPtr))); NEXT_INST_F(9, 1, 0); - } else { - Tcl_SetObjResult(interp, OBJ_UNDER_TOS); - if (*pc == INST_SYNTAX) { - iPtr->flags &= ~ERR_ALREADY_LOGGED; - } - cleanup = 2; - goto processExceptionReturn; } + Tcl_SetObjResult(interp, OBJ_UNDER_TOS); + if (*pc == INST_SYNTAX) { + iPtr->flags &= ~ERR_ALREADY_LOGGED; + } + cleanup = 2; + goto processExceptionReturn; } case INST_RETURN_STK: @@ -2259,11 +2269,10 @@ TclExecuteByteCode( TRACE_APPEND(("continuing to next instruction (TRESULT=\"%.30s\")", O2S(objResultPtr))); NEXT_INST_F(1, 0, 0); - } else { - Tcl_SetObjResult(interp, objResultPtr); - cleanup = 1; - goto processExceptionReturn; } + Tcl_SetObjResult(interp, objResultPtr); + cleanup = 1; + goto processExceptionReturn; case INST_DONE: if (tosPtr > initTosPtr) { @@ -2394,10 +2403,9 @@ TclExecuteByteCode( a = tosPtr-(opnd-1); b = tosPtr; while (a ERROR: ", O2S(objPtr)), Tcl_GetObjResult(interp)); goto gotError; @@ -2654,10 +2661,6 @@ TclExecuteByteCode( * INVOCATION BLOCK */ - { - int objc, pcAdjustment; - Tcl_Obj **objv; - instEvalStk: case INST_EVAL_STK: /* @@ -2692,7 +2695,14 @@ TclExecuteByteCode( Tcl_IncrRefCount(copyPtr); OBJ_AT_TOS = copyPtr; listRepPtr = copyPtr->internalRep.twoPtrValue.ptr1; - Tcl_DecrRefCount(objPtr); + + /* + * Decrement the refcount on the *original* copy of the + * list directly; we know it was greater than 1 here so it + * can't be deallocated. + */ + + objPtr->refCount--; } objc = listRepPtr->elemCount; objv = &listRepPtr->elements; @@ -2975,7 +2985,7 @@ TclExecuteByteCode( NEXT_INST_V(0, cleanup, -1); #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 @@ -2983,9 +2993,6 @@ TclExecuteByteCode( * function into the stack. */ - int numArgs; - Tcl_Obj *tmpPtr1, *tmpPtr2; - opnd = TclGetUInt1AtPtr(pc+1); if ((opnd < 0) || (opnd > LAST_BUILTIN_FUNC)) { TRACE(("UNRECOGNIZED BUILTIN FUNC CODE %d\n", opnd)); @@ -2999,30 +3006,32 @@ TclExecuteByteCode( * Only 0, 1 or 2 args. */ - numArgs = tclBuiltinFuncTable[opnd].numArgs; - 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); + { + int numArgs = tclBuiltinFuncTable[opnd].numArgs; + Tcl_Obj *tmpPtr1, *tmpPtr2; + + if (numArgs == 0) { + PUSH_OBJECT(objPtr); + } else if (numArgs == 1) { + tmpPtr1 = POP_OBJECT(); + PUSH_OBJECT(objPtr); + PUSH_OBJECT(tmpPtr1); + Tcl_DecrRefCount(tmpPtr1); + } else { + tmpPtr2 = POP_OBJECT(); + tmpPtr1 = POP_OBJECT(); + PUSH_OBJECT(objPtr); + PUSH_OBJECT(tmpPtr1); + PUSH_OBJECT(tmpPtr2); + Tcl_DecrRefCount(tmpPtr1); + Tcl_DecrRefCount(tmpPtr2); + } + objc = numArgs + 1; } - - 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 @@ -3030,13 +3039,8 @@ TclExecuteByteCode( * ::tcl::mathfunc::$objv[0]. */ - Tcl_Obj *tmpPtr; - - /* - * 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); TclNewLiteralStringObj(tmpPtr, "::tcl::mathfunc::"); @@ -3052,7 +3056,6 @@ TclExecuteByteCode( pcAdjustment = 2; goto doInvocation; - } #else /* * INST_CALL_BUILTIN_FUNC1 and INST_CALL_FUNC1 were made obsolete by the @@ -3065,7 +3068,6 @@ TclExecuteByteCode( case INST_CALL_FUNC1: Tcl_Panic("TclExecuteByteCode: obsolete INST_CALL_FUNC1 found"); #endif - } /* * ----------------------------------------------------------------- @@ -3075,8 +3077,6 @@ TclExecuteByteCode( * instructions set the value of some variables and then jump to some * common execution code. */ - { - int pcAdjustment; case INST_LOAD_SCALAR1: instLoadScalar1: @@ -3213,7 +3213,6 @@ TclExecuteByteCode( } TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); NEXT_INST_V(pcAdjustment, cleanup, 1); - } /* * End of INST_LOAD instructions. @@ -3226,7 +3225,7 @@ TclExecuteByteCode( */ { - int pcAdjustment, storeFlags; + int storeFlags; case INST_STORE_ARRAY4: opnd = TclGetUInt4AtPtr(pc+1); @@ -3482,11 +3481,10 @@ TclExecuteByteCode( { Tcl_Obj *incrPtr; - int pcAdjustment; #ifndef NO_WIDE_TYPE Tcl_WideInt w; #endif - long i; + long increment; case INST_INCR_SCALAR1: case INST_INCR_ARRAY1: @@ -3510,8 +3508,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; @@ -3521,11 +3519,11 @@ 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; @@ -3543,8 +3541,8 @@ TclExecuteByteCode( 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; @@ -3556,7 +3554,7 @@ TclExecuteByteCode( 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) { @@ -3568,7 +3566,7 @@ TclExecuteByteCode( case INST_INCR_SCALAR1_IMM: opnd = TclGetUInt1AtPtr(pc+1); - i = TclGetInt1AtPtr(pc+2); + increment = TclGetInt1AtPtr(pc+2); pcAdjustment = 3; cleanup = 0; varPtr = LOCAL(opnd); @@ -3584,16 +3582,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); @@ -3608,10 +3606,10 @@ TclExecuteByteCode( #ifndef NO_WIDE_TYPE w = (Tcl_WideInt)augend; - TRACE(("%u %ld => ", opnd, i)); + TRACE(("%u %ld => ", opnd, increment)); if (Tcl_IsShared(objPtr)) { objPtr->refCount--; /* We know it's shared. */ - objResultPtr = Tcl_NewWideIntObj(w+i); + objResultPtr = Tcl_NewWideIntObj(w+increment); Tcl_IncrRefCount(objResultPtr); varPtr->value.objPtr = objResultPtr; } else { @@ -3622,7 +3620,7 @@ TclExecuteByteCode( * use macro form that doesn't range test again. */ - TclSetWideIntObj(objPtr, w+i); + TclSetWideIntObj(objPtr, w+increment); } goto doneIncr; #endif @@ -3632,14 +3630,14 @@ TclExecuteByteCode( Tcl_WideInt sum; w = *((const Tcl_WideInt *) ptr); - sum = w + i; + 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); @@ -3669,14 +3667,14 @@ TclExecuteByteCode( } else { objResultPtr = objPtr; } - TclNewLongObj(incrPtr, i); - TRESULT = TclIncrObj(interp, objResultPtr, incrPtr); - Tcl_DecrRefCount(incrPtr); - if (TRESULT != TCL_OK) { + TclNewLongObj(incrPtr, increment); + if (TclIncrObj(interp, objResultPtr, incrPtr) != TCL_OK) { + Tcl_DecrRefCount(incrPtr); TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); goto gotError; } + Tcl_DecrRefCount(incrPtr); goto doneIncr; } @@ -3684,7 +3682,7 @@ TclExecuteByteCode( * All other cases, flow through to generic handling. */ - TclNewLongObj(incrPtr, i); + TclNewLongObj(incrPtr, increment); Tcl_IncrRefCount(incrPtr); doIncrScalar: @@ -3695,7 +3693,7 @@ TclExecuteByteCode( arrayPtr = NULL; part1Ptr = part2Ptr = NULL; cleanup = 0; - TRACE(("%u %ld => ", opnd, i)); + TRACE(("%u %ld => ", opnd, increment)); doIncrVar: if (TclIsVarDirectModifyable2(varPtr, arrayPtr)) { @@ -3708,14 +3706,13 @@ TclExecuteByteCode( } else { objResultPtr = objPtr; } - TRESULT = TclIncrObj(interp, objResultPtr, incrPtr); - Tcl_DecrRefCount(incrPtr); - if (TRESULT != TCL_OK) { + if (TclIncrObj(interp, objResultPtr, incrPtr) != TCL_OK) { + Tcl_DecrRefCount(incrPtr); TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); goto gotError; } - goto doneIncr; + Tcl_DecrRefCount(incrPtr); } else { DECACHE_STACK_INFO(); objResultPtr = TclPtrIncrObjVar(interp, varPtr, arrayPtr, @@ -3842,7 +3839,7 @@ TclExecuteByteCode( */ { - int flags, localResult; + int flags; case INST_UNSET_SCALAR: flags = TclGetUInt1AtPtr(pc+1) ? TCL_LEAVE_ERR_MSG : 0; @@ -3859,7 +3856,7 @@ TclExecuteByteCode( */ if (!TclIsVarUndefined(varPtr)) { - Tcl_DecrRefCount(varPtr->value.objPtr); + TclDecrRefCount(varPtr->value.objPtr); } else if (flags & TCL_LEAVE_ERR_MSG) { goto slowUnsetScalar; } @@ -3869,12 +3866,11 @@ TclExecuteByteCode( slowUnsetScalar: DECACHE_STACK_INFO(); - localResult = TclPtrUnsetVar(interp, varPtr, NULL, NULL, NULL, flags, - opnd); - CACHE_STACK_INFO(); - if (localResult != TCL_OK && flags) { + if (TclPtrUnsetVar(interp, varPtr, NULL, NULL, NULL, flags, + opnd) != TCL_OK && flags) { goto errorInUnset; } + CACHE_STACK_INFO(); NEXT_INST_F(6, 0, 0); case INST_UNSET_ARRAY: @@ -3885,7 +3881,8 @@ TclExecuteByteCode( while (TclIsVarLink(arrayPtr)) { arrayPtr = arrayPtr->value.linkPtr; } - TRACE(("%s %u \"%.30s\"\n", (flags?"normal":"noerr"), opnd, O2S(part2Ptr))); + 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)) { @@ -3895,32 +3892,33 @@ TclExecuteByteCode( */ if (!TclIsVarUndefined(varPtr)) { - Tcl_DecrRefCount(varPtr->value.objPtr); + TclDecrRefCount(varPtr->value.objPtr); } else if (flags & TCL_LEAVE_ERR_MSG) { goto slowUnsetArray; } varPtr->value.objPtr = NULL; NEXT_INST_F(6, 1, 0); + } else if (!varPtr && !(flags & TCL_LEAVE_ERR_MSG)) { + /* + * Don't need to do anything here. + */ + + NEXT_INST_F(6, 1, 0); } } slowUnsetArray: DECACHE_STACK_INFO(); varPtr = TclLookupArrayElement(interp, NULL, part2Ptr, flags, "unset", 0, 0, arrayPtr, opnd); - if (!varPtr && (flags & TCL_LEAVE_ERR_MSG)) { - CACHE_STACK_INFO(); + 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; } - if (varPtr) { - localResult = TclPtrUnsetVar(interp, varPtr, arrayPtr, NULL, - part2Ptr, flags, opnd); - } else { - localResult = TCL_OK; - } CACHE_STACK_INFO(); - if (localResult != TCL_OK && (flags & TCL_LEAVE_ERR_MSG)) { - goto errorInUnset; - } NEXT_INST_F(6, 1, 0); case INST_UNSET_ARRAY_STK: @@ -3941,14 +3939,15 @@ TclExecuteByteCode( doUnsetStk: DECACHE_STACK_INFO(); - localResult = TclObjUnsetVar2(interp, part1Ptr, part2Ptr, flags); - CACHE_STACK_INFO(); - if (localResult != TCL_OK && (flags & TCL_LEAVE_ERR_MSG)) { + if (TclObjUnsetVar2(interp, part1Ptr, part2Ptr, flags) != TCL_OK + && (flags & TCL_LEAVE_ERR_MSG)) { goto errorInUnset; } + CACHE_STACK_INFO(); NEXT_INST_V(2, cleanup, 0); errorInUnset: + CACHE_STACK_INFO(); TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); goto gotError; } @@ -3961,14 +3960,14 @@ TclExecuteByteCode( { Var *otherPtr; - - case INST_UPVAR: { CallFrame *framePtr, *savedFramePtr; + Tcl_Namespace *nsPtr; + Namespace *savedNsPtr; + case INST_UPVAR: TRACE_WITH_OBJ(("upvar "), OBJ_UNDER_TOS); - TRESULT = TclObjGetFrame(interp, OBJ_UNDER_TOS, &framePtr); - if (TRESULT == -1) { + if (TclObjGetFrame(interp, OBJ_UNDER_TOS, &framePtr) == -1) { goto gotError; } @@ -3982,16 +3981,12 @@ TclExecuteByteCode( TCL_LEAVE_ERR_MSG, "access", /*createPart1*/ 1, /*createPart2*/ 1, &varPtr); iPtr->varFramePtr = savedFramePtr; - if (otherPtr) { - goto doLinkVars; + if (!otherPtr) { + goto gotError; } - goto gotError; - } - - case INST_NSUPVAR: { - Tcl_Namespace *nsPtr; - Namespace *savedNsPtr; + goto doLinkVars; + case INST_NSUPVAR: TRACE_WITH_OBJ(("nsupvar "), OBJ_UNDER_TOS); if (TclGetNamespaceFromObj(interp, OBJ_UNDER_TOS, &nsPtr) != TCL_OK) { goto gotError; @@ -4011,7 +4006,6 @@ TclExecuteByteCode( goto gotError; } goto doLinkVars; - } case INST_VARIABLE: TRACE(("variable ")); @@ -4040,7 +4034,6 @@ TclExecuteByteCode( varPtr = LOCAL(opnd); if ((varPtr != otherPtr) && !TclIsVarTraced(varPtr) && (TclIsVarUndefined(varPtr) || TclIsVarLink(varPtr))) { - TRESULT = TCL_OK; if (!TclIsVarUndefined(varPtr)) { /* * Then it is a defined link. @@ -4221,6 +4214,11 @@ TclExecuteByteCode( * Start of INST_LIST and related instructions. */ + { + int index, numIndices, fromIdx, toIdx; + int nocase, match, length2, cflags, s1len, s2len; + const char *s1, *s2; + case INST_LIST: /* * Pop the opnd (objc) top stack elements into a new list obj and then @@ -4234,7 +4232,6 @@ TclExecuteByteCode( 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)); @@ -4244,18 +4241,7 @@ TclExecuteByteCode( TRACE(("%.20s => %d\n", O2S(valuePtr), length)); NEXT_INST_F(1, 1, 1); - case INST_LIST_INDEX: { - /*** lindex with objc == 3 ***/ - - /* Variables also for INST_LIST_INDEX_IMM */ - - int listc, idx, pcAdjustment; - Tcl_Obj **listv; - - /* - * Pop the two operands. - */ - + case INST_LIST_INDEX: /* lindex with objc == 3 */ value2Ptr = OBJ_AT_TOS; valuePtr = OBJ_UNDER_TOS; @@ -4263,10 +4249,10 @@ TclExecuteByteCode( * Extract the desired list element. */ - TRESULT = TclListObjGetElements(interp, valuePtr, &listc, &listv); - if ((TRESULT == 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; @@ -4288,10 +4274,8 @@ TclExecuteByteCode( 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 ***/ - - pcAdjustment = 5; + case INST_LIST_INDEX_IMM: /* lindex with objc==3 and index in bytecode + * stream */ /* * Pop the list and get the index. @@ -4305,7 +4289,7 @@ TclExecuteByteCode( * in the process. */ - if (TclListObjGetElements(interp, valuePtr, &listc, &listv)!=TCL_OK) { + if (TclListObjGetElements(interp, valuePtr, &objc, &objv) != TCL_OK) { TRACE_WITH_OBJ(("\"%.30s\" %d => ERROR: ", O2S(valuePtr), opnd), Tcl_GetObjResult(interp)); goto gotError; @@ -4317,14 +4301,15 @@ TclExecuteByteCode( */ if (opnd < -1) { - idx = opnd+1 + listc; + index = opnd+1 + objc; } else { - idx = opnd; + index = opnd; } + pcAdjustment = 5; lindexFastPath: - if (idx >= 0 && idx < listc) { - objResultPtr = listv[idx]; + if (index >= 0 && index < objc) { + objResultPtr = objv[index]; } else { TclNewObj(objResultPtr); } @@ -4332,27 +4317,21 @@ TclExecuteByteCode( TRACE_WITH_OBJ(("\"%.30s\" %d => ", O2S(valuePtr), opnd), objResultPtr); NEXT_INST_F(pcAdjustment, 1, 1); - } - { - int numIdx; - - case INST_LIST_INDEX_MULTI: + case INST_LIST_INDEX_MULTI: /* 'lindex' with multiple index args */ /* - * 'lindex' with multiple index args: - * * Determine the count of index args. */ 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; @@ -4371,7 +4350,7 @@ TclExecuteByteCode( */ opnd = TclGetUInt4AtPtr(pc + 1); - numIdx = opnd - 2; + numIndices = opnd - 2; /* * Get the old value of variable, and remove the stack ref. This is @@ -4380,21 +4359,15 @@ 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); + objResultPtr = TclLsetFlat(interp, valuePtr, numIndices, + &OBJ_AT_DEPTH(numIndices), OBJ_AT_TOS); if (!objResultPtr) { TRACE_WITH_OBJ(("%d => ERROR: ", opnd), Tcl_GetObjResult(interp)); goto gotError; @@ -4405,13 +4378,10 @@ TclExecuteByteCode( */ TRACE(("%d => %s\n", opnd, O2S(objResultPtr))); - NEXT_INST_V(5, (numIdx+1), -1); - } + NEXT_INST_V(5, numIndices+1, -1); - case INST_LSET_LIST: + case INST_LSET_LIST: /* 'lset' with 4 args */ /* - * 'lset' with 4 args. - * * Get the old value of variable, and remove the stack ref. This is * safe because the variable still references the object; the ref * count will never go zero here - we can use the smaller macro @@ -4446,11 +4416,8 @@ TclExecuteByteCode( TRACE(("=> %s\n", O2S(objResultPtr))); NEXT_INST_F(1, 2, -1); - case INST_LIST_RANGE_IMM: { - /*** lrange with objc==4 and both indices in bytecode stream ***/ - - int listc, fromIdx, toIdx; - Tcl_Obj **listv; + case INST_LIST_RANGE_IMM: /* lrange with objc==4 and both indices in + * bytecode stream */ /* * Pop the list and get the indices. @@ -4465,7 +4432,7 @@ TclExecuteByteCode( * in the process. */ - if (TclListObjGetElements(interp, valuePtr, &listc, &listv)!=TCL_OK) { + if (TclListObjGetElements(interp, valuePtr, &objc, &objv) != TCL_OK) { TRACE_WITH_OBJ(("\"%.30s\" %d %d => ERROR: ", O2S(valuePtr), fromIdx, toIdx), Tcl_GetObjResult(interp)); goto gotError; @@ -4487,20 +4454,20 @@ TclExecuteByteCode( */ 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; } /* @@ -4508,14 +4475,14 @@ TclExecuteByteCode( * so, build the list of elements in that range. */ - if (fromIdx<=toIdx && fromIdx=0) { + if (fromIdx<=toIdx && fromIdx=0) { if (fromIdx<0) { fromIdx = 0; } - if (toIdx >= listc) { - toIdx = listc-1; + if (toIdx >= objc) { + toIdx = objc-1; } - objResultPtr = Tcl_NewListObj(toIdx-fromIdx+1, listv+fromIdx); + objResultPtr = Tcl_NewListObj(toIdx-fromIdx+1, objv+fromIdx); } else { TclNewObj(objResultPtr); } @@ -4523,56 +4490,48 @@ 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; - const char *s1, *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); - if (TclListObjLength(interp, value2Ptr, &llen) != TCL_OK) { + if (TclListObjLength(interp, value2Ptr, &length) != TCL_OK) { TRACE_WITH_OBJ(("\"%.30s\" \"%.30s\" => ERROR: ", O2S(valuePtr), O2S(value2Ptr)), Tcl_GetObjResult(interp)); goto gotError; } + match = 0; + if (length > 0) { + int i = 0; + Tcl_Obj *o; - found = 0; - if (llen > 0) { /* * An empty list doesn't match anything. */ - i = 0; do { - Tcl_Obj *o; - Tcl_ListObjIndex(NULL, value2Ptr, i, &o); if (o != NULL) { s2 = TclGetStringFromObj(o, &s2len); } else { - s2 = ""; s2len = 0; + s2 = ""; + s2len = 0; } if (s1len == s2len) { - found = (strcmp(s1, s2) == 0); + match = (strcmp(s1, s2) == 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. @@ -4584,18 +4543,17 @@ 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 = TCONST(found); + objResultPtr = TCONST(match); NEXT_INST_F(0, 2, 1); - } /* * End of INST_LIST and related instructions. @@ -4604,14 +4562,11 @@ TclExecuteByteCode( */ case INST_STR_EQ: - case INST_STR_NEQ: { + case INST_STR_NEQ: /* String (in)equality check */ /* - * String (in)equality check * TODO: Consider merging into INST_STR_CMP */ - int iResult; - value2Ptr = OBJ_AT_TOS; valuePtr = OBJ_UNDER_TOS; @@ -4621,11 +4576,8 @@ TclExecuteByteCode( * really have to think hard about equality. */ - iResult = (*pc == INST_STR_EQ); + match = (*pc == INST_STR_EQ); } else { - const char *s1, *s2; - int s1len, s2len; - s1 = TclGetStringFromObj(valuePtr, &s1len); s2 = TclGetStringFromObj(value2Ptr, &s2len); if (s1len == s2len) { @@ -4635,17 +4587,17 @@ TclExecuteByteCode( */ if (*pc == INST_STR_NEQ) { - iResult = (strcmp(s1, s2) != 0); + match = (strcmp(s1, s2) != 0); } else { /* INST_STR_EQ */ - iResult = (strcmp(s1, s2) == 0); + match = (strcmp(s1, s2) == 0); } } else { - iResult = (*pc == INST_STR_NEQ); + match = (*pc == INST_STR_NEQ); } } - TRACE(("%.20s %.20s => %d\n", O2S(valuePtr),O2S(value2Ptr),iResult)); + TRACE(("%.20s %.20s => %d\n", O2S(valuePtr),O2S(value2Ptr),match)); /* * Peep-hole optimisation: if you're about to jump, do jump from here. @@ -4655,28 +4607,20 @@ TclExecuteByteCode( #ifndef TCL_COMPILE_DEBUG switch (*pc) { case INST_JUMP_FALSE1: - NEXT_INST_F((iResult? 2 : TclGetInt1AtPtr(pc+1)), 2, 0); + NEXT_INST_F((match? 2 : TclGetInt1AtPtr(pc+1)), 2, 0); case INST_JUMP_TRUE1: - NEXT_INST_F((iResult? TclGetInt1AtPtr(pc+1) : 2), 2, 0); + NEXT_INST_F((match? TclGetInt1AtPtr(pc+1) : 2), 2, 0); case INST_JUMP_FALSE4: - NEXT_INST_F((iResult? 5 : TclGetInt4AtPtr(pc+1)), 2, 0); + NEXT_INST_F((match? 5 : TclGetInt4AtPtr(pc+1)), 2, 0); case INST_JUMP_TRUE4: - NEXT_INST_F((iResult? TclGetInt4AtPtr(pc+1) : 5), 2, 0); + NEXT_INST_F((match? TclGetInt4AtPtr(pc+1) : 5), 2, 0); } #endif - objResultPtr = TCONST(iResult); + objResultPtr = TCONST(match); NEXT_INST_F(0, 2, 1); - } - - case INST_STR_CMP: { - /* - * String compare. - */ - - const char *s1, *s2; - int s1len, s2len, iResult; stringCompare: + case INST_STR_CMP: /* String compare. */ value2Ptr = OBJ_AT_TOS; valuePtr = OBJ_UNDER_TOS; @@ -4691,12 +4635,12 @@ TclExecuteByteCode( * (or we could goto beyond it). */ - iResult = s1len = s2len = 0; + match = s1len = s2len = 0; } else if (TclIsPureByteArray(valuePtr) && TclIsPureByteArray(value2Ptr)) { s1 = (char *) Tcl_GetByteArrayFromObj(valuePtr, &s1len); s2 = (char *) Tcl_GetByteArrayFromObj(value2Ptr, &s2len); - iResult = memcmp(s1, s2, + match = memcmp(s1, s2, (size_t) ((s1len < s2len) ? s1len : s2len)); } else if (((valuePtr->typePtr == &tclStringType) && (value2Ptr->typePtr == &tclStringType))) { @@ -4710,10 +4654,10 @@ TclExecuteByteCode( s1len = Tcl_GetCharLength(valuePtr); s2len = Tcl_GetCharLength(value2Ptr); if ((s1len == valuePtr->length) && (s2len == value2Ptr->length)) { - iResult = memcmp(valuePtr->bytes, value2Ptr->bytes, + match = memcmp(valuePtr->bytes, value2Ptr->bytes, (unsigned) ((s1len < s2len) ? s1len : s2len)); } else { - iResult = TclUniCharNcmp(Tcl_GetUnicode(valuePtr), + match = TclUniCharNcmp(Tcl_GetUnicode(valuePtr), Tcl_GetUnicode(value2Ptr), (unsigned) ((s1len < s2len) ? s1len : s2len)); } @@ -4725,7 +4669,7 @@ TclExecuteByteCode( s1 = TclGetStringFromObj(valuePtr, &s1len); s2 = TclGetStringFromObj(value2Ptr, &s2len); - iResult = TclpUtfNcmp2(s1, s2, + match = TclpUtfNcmp2(s1, s2, (size_t) ((s1len < s2len) ? s1len : s2len)); } @@ -4734,8 +4678,8 @@ TclExecuteByteCode( * TODO: consider peephole opt. */ - if (iResult == 0) { - iResult = s1len - s2len; + if (match == 0) { + match = s1len - s2len; } if (*pc != INST_STR_CMP) { @@ -4745,52 +4689,42 @@ TclExecuteByteCode( switch (*pc) { case INST_EQ: - iResult = (iResult == 0); + match = (match == 0); break; 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 = TCONST(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: valuePtr = OBJ_AT_TOS; - length = Tcl_GetCharLength(valuePtr); TclNewIntObj(objResultPtr, length); TRACE(("%.20s => %d\n", O2S(valuePtr), length)); NEXT_INST_F(1, 1, 1); - case INST_STR_INDEX: { - /* - * String compare. - */ - - int index; - + case INST_STR_INDEX: value2Ptr = OBJ_AT_TOS; valuePtr = OBJ_UNDER_TOS; @@ -4803,40 +4737,33 @@ TclExecuteByteCode( goto gotError; } - if ((index >= 0) && (index < length)) { - 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; - - ch = Tcl_GetUniChar(valuePtr, index); + 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); - /* - * This could be: Tcl_NewUnicodeObj((const Tcl_UniChar *)&ch, - * 1) but creating the object as a string seems to be faster - * in practical use. - */ + /* + * This could be: Tcl_NewUnicodeObj((const Tcl_UniChar *)&ch, 1) + * but creating the object as a string seems to be faster in + * practical use. + */ - length = Tcl_UniCharToUtf(ch, buf); - objResultPtr = Tcl_NewStringObj(buf, length); - } - } else { - TclNewObj(objResultPtr); + length = Tcl_UniCharToUtf(ch, buf); + objResultPtr = Tcl_NewStringObj(buf, length); } TRACE(("%.20s %.20s => %s\n", O2S(valuePtr), O2S(value2Ptr), O2S(objResultPtr))); NEXT_INST_F(1, 2, 1); - } - - case INST_STR_MATCH: { - int nocase, match, length2; + case INST_STR_MATCH: nocase = TclGetInt1AtPtr(pc+1); valuePtr = OBJ_AT_TOS; /* String */ value2Ptr = OBJ_UNDER_TOS; /* Pattern */ @@ -4855,11 +4782,11 @@ TclExecuteByteCode( match = TclUniCharMatch(ustring1, length, ustring2, length2, nocase); } else if (TclIsPureByteArray(valuePtr) && !nocase) { - unsigned char *string1, *string2; + unsigned char *bytes1, *bytes2; - string1 = Tcl_GetByteArrayFromObj(valuePtr, &length); - string2 = Tcl_GetByteArrayFromObj(value2Ptr, &length2); - match = TclByteArrayMatch(string1, length, 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); @@ -4891,38 +4818,42 @@ TclExecuteByteCode( #endif objResultPtr = TCONST(match); NEXT_INST_F(0, 2, 1); - } - - case INST_REGEXP: { - int cflags, match; - Tcl_RegExp regExpr; + 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 { - match = Tcl_RegExpExecObj(interp, regExpr, valuePtr, 0, 0, 0); - } - /* - * Adjustment is 2 due to the nocase byte + * Compile and match the regular expression. */ - if (match < 0) { - objResultPtr = Tcl_GetObjResult(interp); - TRACE_WITH_OBJ(("%.20s %.20s => ERROR: ", - O2S(valuePtr), O2S(value2Ptr)), objResultPtr); - goto gotError; + { + 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)); /* * Peep-hole optimisation: if you're about to jump, do jump from here. + * Adjustment is 2 due to the nocase byte. */ pc += 2; @@ -4951,10 +4882,7 @@ TclExecuteByteCode( { ClientData ptr1, ptr2; int type1, type2; - double d1, d2, dResult; long l1, l2, lResult; - mp_int big1, big2, bigResult, bigRemainder; - Tcl_WideInt w1, w2, wResult; case INST_EQ: case INST_NEQ: @@ -4963,7 +4891,6 @@ TclExecuteByteCode( case INST_LE: case INST_GE: { int iResult = 0, compare = 0; - double tmp; value2Ptr = OBJ_AT_TOS; valuePtr = OBJ_UNDER_TOS; @@ -5002,249 +4929,39 @@ 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; - } + l2 = *((const long *)ptr2); + compare = (l1 < l2) ? MP_LT : ((l1 > l2) ? MP_GT : MP_EQ); + } else { + compare = TclCompareTwoNumbers(valuePtr, value2Ptr); + } - /* - * 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. - */ + /* + * Turn comparison outcome into appropriate result for opcode. + */ - 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); - } + convertComparison: + switch (*pc) { + case INST_EQ: + iResult = (compare == MP_EQ); 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); - } + case INST_NEQ: + iResult = (compare != MP_EQ); 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); - } - } - - /* - * Turn comparison outcome into appropriate result for opcode. - */ - - convertComparison: - switch (*pc) { - case INST_EQ: - iResult = (compare == MP_EQ); - break; - case INST_NEQ: - iResult = (compare != MP_EQ); - break; - case INST_LT: - iResult = (compare == MP_LT); - break; - case INST_GT: - iResult = (compare == MP_GT); - break; - case INST_LE: - iResult = (compare != MP_GT); - break; - case INST_GE: - iResult = (compare != MP_LT); - break; - } + case INST_LT: + iResult = (compare == MP_LT); + break; + case INST_GT: + iResult = (compare == MP_GT); + break; + case INST_LE: + iResult = (compare != MP_GT); + break; + case INST_GE: + iResult = (compare != MP_LT); + break; + } /* * Peep-hole optimisation: if you're about to jump, do jump from here. @@ -5270,16 +4987,15 @@ TclExecuteByteCode( case INST_MOD: case INST_LSHIFT: - case INST_RSHIFT: { - int invalid, shift; - - l1 = 0; + case INST_RSHIFT: + case INST_BITOR: + case INST_BITXOR: + case INST_BITAND: value2Ptr = OBJ_AT_TOS; valuePtr = OBJ_UNDER_TOS; - TRESULT = GetNumberFromObj(NULL, valuePtr, &ptr1, &type1); - if ((TRESULT != TCL_OK) || (type1 == TCL_NUMBER_DOUBLE) - || (type1 == TCL_NUMBER_NAN)) { + 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"))); @@ -5287,9 +5003,8 @@ TclExecuteByteCode( goto gotError; } - TRESULT = GetNumberFromObj(NULL, value2Ptr, &ptr2, &type2); - if ((TRESULT != TCL_OK) || (type2 == TCL_NUMBER_DOUBLE) - || (type2 == TCL_NUMBER_NAN)) { + 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"))); @@ -5297,2656 +5012,2962 @@ TclExecuteByteCode( goto gotError; } - if (*pc == INST_MOD) { - /* TODO: Attempts to re-use unshared operands on stack */ + /* + * Check for common, simple case. + */ + + if ((type1 == TCL_NUMBER_LONG) && (type2 == TCL_NUMBER_LONG)) { + l1 = *((const long *)ptr1); + l2 = *((const long *)ptr2); - l2 = 0; /* silence gcc warning */ - 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. */ + 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. */ + 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. - */ + case INST_RSHIFT: + if (l2 < 0) { + Tcl_SetResult(interp, "negative shift argument", + TCL_STATIC); +#if 0 + Tcl_SetErrorCode(interp, "ARITH", "DOMAIN", + "domain error: argument not in valid range", + NULL); +#endif + goto gotError; + } else if (l1 == 0) { + TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); + objResultPtr = TCONST(0); + TRACE(("%s\n", O2S(objResultPtr))); + NEXT_INST_F(1, 2, 1); + } else { + /* + * Quickly force large right shifts to 0 or -1. + */ -#ifndef NO_WIDE_TYPE - if (type2 == TCL_NUMBER_WIDE) { - w2 = *((const Tcl_WideInt *)ptr2); - if ((l1 > 0) ^ (w2 > (Tcl_WideInt)0)) { + if (l2 >= 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... */ - objResultPtr = Tcl_NewWideIntObj(w2+(Tcl_WideInt)l1); + 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. */ - TRACE(("%s\n", O2S(valuePtr))); - NEXT_INST_F(1, 1, 0); + lResult = l1 >> ((int) l2); + goto longResultOfArithmetic; } -#endif - Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2); - /* TODO: internals intrusion */ - if ((l1 > 0) ^ (big2.sign == MP_ZPOS)) { - /* - * Arguments are opposite sign; remainder is sum. - */ - - TclBNInitBignumFromLong(&big1, l1); - mp_add(&big2, &big1, &big2); - mp_clear(&big1); - objResultPtr = Tcl_NewBignumObj(&big2); + case INST_LSHIFT: + if (l2 < 0) { + Tcl_SetResult(interp, "negative shift argument", + TCL_STATIC); +#if 0 + Tcl_SetErrorCode(interp, "ARITH", "DOMAIN", + "domain error: argument not in valid range", + NULL); +#endif + goto gotError; + } else if (l1 == 0) { + TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); + objResultPtr = TCONST(0); TRACE(("%s\n", O2S(objResultPtr))); NEXT_INST_F(1, 2, 1); - } - - /* - * 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) { - w1 = *((const Tcl_WideInt *)ptr1); - if (type2 != TCL_NUMBER_BIG) { - Tcl_WideInt wQuotient, wRemainder; + } else if (l2 > (long) INT_MAX) { + /* + * Technically, we could hold the value (1 << (INT_MAX+1)) + * in an mp_int, but since we're using mp_mul_2d() to do + * the work, and it takes only an int argument, that's a + * good place to draw the line. + */ - Tcl_GetWideIntFromObj(NULL, value2Ptr, &w2); - wQuotient = w1 / w2; + Tcl_SetResult(interp, + "integer value too large to represent", + TCL_STATIC); +#if 0 + Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", + "integer value too large to represent", NULL); +#endif + goto gotError; + } else { + int shift = (int) l2; /* - * Force Tcl's integer division rules. - * TODO: examine for logic simplification + * Handle shifts within the native long range. */ - 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; + 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; } - wRemainder = w1 - w2*wQuotient; - objResultPtr = Tcl_NewWideIntObj(wRemainder); - TRACE(("%s\n", O2S(objResultPtr))); - NEXT_INST_F(1, 2, 1); } - Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2); + /* + * Too large; need to use the broken-out function. + */ - /* TODO: internals intrusion */ - if ((w1 > ((Tcl_WideInt) 0)) ^ (big2.sign == MP_ZPOS)) { - /* - * Arguments are opposite sign; remainder is sum. - */ + TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); + break; - TclBNInitBignumFromWideInt(&big1, w1); - mp_add(&big2, &big1, &big2); - mp_clear(&big1); - objResultPtr = Tcl_NewBignumObj(&big2); + case INST_BITAND: + lResult = l1 & l2; + goto longResultOfArithmetic; + case INST_BITOR: + lResult = l1 | l2; + goto longResultOfArithmetic; + case INST_BITXOR: + lResult = l1 ^ l2; + longResultOfArithmetic: + TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); + if (Tcl_IsShared(valuePtr)) { + TclNewLongObj(objResultPtr, lResult); TRACE(("%s\n", O2S(objResultPtr))); NEXT_INST_F(1, 2, 1); } - - /* - * Arguments are same sign; remainder is first operand. - */ - - mp_clear(&big2); + TclSetLongObj(valuePtr, lResult); TRACE(("%s\n", O2S(valuePtr))); NEXT_INST_F(1, 1, 0); } -#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); - 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. + * DO NOT MERGE THIS WITH THE EQUIVALENT SECTION LATER! That would + * encourage the compiler to inline ExecuteExtendedBinaryMathOp, which + * is highly undesirable due to the overall impact on size. */ - switch (type2) { - case TCL_NUMBER_LONG: - invalid = (*((const long *)ptr2) < (long)0); - break; -#ifndef NO_WIDE_TYPE - case TCL_NUMBER_WIDE: - invalid = (*((const Tcl_WideInt *)ptr2) < (Tcl_WideInt)0); - break; -#endif - case TCL_NUMBER_BIG: - Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2); - invalid = (mp_cmp_d(&big2, 0) == MP_LT); - mp_clear(&big2); - break; - default: - /* Unused, here to silence compiler warning */ - invalid = 0; - } - if (invalid) { - Tcl_SetResult(interp, "negative shift argument", TCL_STATIC); + 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); } - /* - * Zero shifted any number of bits is still zero. - */ + case INST_EXPON: + case INST_ADD: + case INST_SUB: + case INST_DIV: + case INST_MULT: + value2Ptr = OBJ_AT_TOS; + valuePtr = OBJ_UNDER_TOS; - if ((type1==TCL_NUMBER_LONG) && (*((const long *)ptr1) == (long)0)) { - TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); - objResultPtr = TCONST(0); - TRACE(("%s\n", O2S(objResultPtr))); - NEXT_INST_F(1, 2, 1); + 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"))); + IllegalExprOperandType(interp, pc, valuePtr); + goto gotError; } - if (*pc == INST_LSHIFT) { +#ifdef ACCEPT_NAN + if (type1 == TCL_NUMBER_NAN) { /* - * 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. + * NaN first argument -> result is also NaN. */ - if ((type2 != TCL_NUMBER_LONG) - || (*((const long *)ptr2) > (long) INT_MAX)) { - /* - * Technically, we could hold the value (1 << (INT_MAX+1)) in - * an mp_int, but since we're using mp_mul_2d() to do the - * work, and it takes only an int argument, that's a good - * place to draw the line. - */ - - Tcl_SetResult(interp, "integer value too large to represent", - TCL_STATIC); - goto gotError; - } - shift = (int)(*((const long *)ptr2)); - - /* - * Handle shifts within the native long range. - */ + NEXT_INST_F(1, 1, 0); + } +#endif - 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< ILLEGAL 2nd TYPE %s\n", + O2S(value2Ptr), O2S(valuePtr), + (value2Ptr->typePtr? value2Ptr->typePtr->name: "null"))); + IllegalExprOperandType(interp, pc, value2Ptr); + goto gotError; + } +#ifdef ACCEPT_NAN + if (type2 == TCL_NUMBER_NAN) { /* - * Handle shifts within the native wide range. + * NaN second argument -> result is also NaN. */ - TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); - 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)))) { - objResultPtr = Tcl_NewWideIntObj(w1< ", O2S(valuePtr), O2S(value2Ptr))); - if ((type2 != TCL_NUMBER_LONG) - || (*(const long *)ptr2 > INT_MAX)) { + /* + * Handle (long,long) arithmetic as best we can without going out to + * an external function. + */ + + if ((type1 == TCL_NUMBER_LONG) && (type2 == TCL_NUMBER_LONG)) { + Tcl_WideInt w1, w2, wResult; + + l1 = *((const long *)ptr1); + l2 = *((const long *)ptr2); + + switch (*pc) { + case INST_ADD: + w1 = (Tcl_WideInt) l1; + w2 = (Tcl_WideInt) l2; + wResult = w1 + w2; +#ifdef NO_WIDE_TYPE /* - * 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. + * Check for overflow. */ - int zero; + if (Overflowing(w1, w2, wResult)) { + goto overflow; + } +#endif + goto wideResultOfArithmetic; + + case INST_SUB: + w1 = (Tcl_WideInt) l1; + w2 = (Tcl_WideInt) l2; + wResult = w1 - w2; +#ifdef NO_WIDE_TYPE + /* + * Must check for overflow. The macro tests for overflows in + * sums by looking at the sign bits. As we have a subtraction + * here, we are adding -w2. As -w2 could in turn overflow, we + * test with ~w2 instead: it has the opposite sign bit to w2 + * so it does the job. Note that the only "bad" case (w2==0) + * is irrelevant for this macro, as in that case w1 and + * wResult have the same sign and there is no overflow anyway. + */ - 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; + if (Overflowing(w1, ~w2, wResult)) { + goto overflow; + } #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; + wideResultOfArithmetic: + TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); + if (Tcl_IsShared(valuePtr)) { + objResultPtr = Tcl_NewWideIntObj(wResult); + TRACE(("%s\n", O2S(objResultPtr))); + NEXT_INST_F(1, 2, 1); } - if (zero) { - objResultPtr = TCONST(0); - } else { - TclNewIntObj(objResultPtr, -1); + Tcl_SetWideIntObj(valuePtr, wResult); + TRACE(("%s\n", O2S(valuePtr))); + NEXT_INST_F(1, 1, 0); + + case INST_DIV: + if (l2 == 0) { + TRACE(("%s %s => DIVIDE BY ZERO\n", + O2S(valuePtr), O2S(value2Ptr))); + goto divideByZero; + } else if ((l1 == LONG_MIN) && (l2 == -1)) { + /* + * Can't represent (-LONG_MIN) as a long. + */ + + goto overflow; } - TRACE(("%s\n", O2S(objResultPtr))); - NEXT_INST_F(1, 2, 1); - } - shift = (int)(*(const long *)ptr2); + lResult = l1 / l2; - /* - * Handle shifts within the native long range. - */ + /* + * Force Tcl's integer division rules. + * TODO: examine for logic simplification + */ - if (type1 == TCL_NUMBER_LONG) { - l1 = *((const long *)ptr1); - if ((size_t)shift >= CHAR_BIT*sizeof(long)) { - if (l1 >= (long)0) { - objResultPtr = TCONST(0); - } else { - TclNewIntObj(objResultPtr, -1); - } - } else { - TclNewLongObj(objResultPtr, (l1 >> shift)); + if (((lResult < 0) || ((lResult == 0) && + ((l1 < 0 && l2 > 0) || (l1 > 0 && l2 < 0)))) && + ((lResult * l2) != l1)) { + lResult -= 1; + } + goto longResultOfArithmetic; + + case INST_MULT: + if (((sizeof(long) >= 2*sizeof(int)) + && (l1 <= INT_MAX) && (l1 >= INT_MIN) + && (l2 <= INT_MAX) && (l2 >= INT_MIN)) + || ((sizeof(long) >= 2*sizeof(short)) + && (l1 <= SHRT_MAX) && (l1 >= SHRT_MIN) + && (l2 <= SHRT_MAX) && (l2 >= SHRT_MIN))) { + lResult = l1 * l2; + goto longResultOfArithmetic; } - TRACE(("%s\n", O2S(objResultPtr))); - NEXT_INST_F(1, 2, 1); } -#ifndef NO_WIDE_TYPE /* - * Handle shifts within the native wide range. + * Fall through with INST_EXPON, INST_DIV and large multiplies. */ - - if (type1 == TCL_NUMBER_WIDE) { - w1 = *(const Tcl_WideInt *)ptr1; - if ((size_t)shift >= CHAR_BIT*sizeof(Tcl_WideInt)) { - if (w1 >= (Tcl_WideInt)0) { - objResultPtr = TCONST(0); - } else { - TclNewIntObj(objResultPtr, -1); - } - } else { - objResultPtr = Tcl_NewWideIntObj(w1 >> shift); - } - TRACE(("%s\n", O2S(objResultPtr))); - NEXT_INST_F(1, 2, 1); - } -#endif } - Tcl_TakeBignumFromObj(NULL, valuePtr, &big1); - - mp_init(&bigResult); - if (*pc == INST_LSHIFT) { - mp_mul_2d(&big1, shift, &bigResult); + overflow: + TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); + objResultPtr = ExecuteExtendedBinaryMathOp(interp, *pc, &TCONST(0), + valuePtr, value2Ptr); + if (objResultPtr == DIVIDED_BY_ZERO) { + TRACE_APPEND(("DIVIDE BY ZERO\n")); + goto divideByZero; + } else if (objResultPtr == EXPONENT_OF_ZERO) { + TRACE_APPEND(("EXPONENT OF ZERO\n")); + goto exponOfZero; + } else if (objResultPtr == GENERAL_ARITHMETIC_ERROR) { + TRACE_APPEND(("ERROR: %s\n", + TclGetString(Tcl_GetObjResult(interp)))); + goto gotError; + } else if (objResultPtr == NULL) { + TRACE_APPEND(("%s\n", O2S(valuePtr))); + NEXT_INST_F(1, 1, 0); } else { - 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); + TRACE_APPEND(("%s\n", O2S(objResultPtr))); + NEXT_INST_F(1, 2, 1); } - mp_clear(&big1); - if (!Tcl_IsShared(valuePtr)) { - Tcl_SetBignumObj(valuePtr, &bigResult); - TRACE(("%s\n", O2S(valuePtr))); - NEXT_INST_F(1, 1, 0); + case INST_LNOT: { + int b; + + valuePtr = OBJ_AT_TOS; + + /* TODO - check claim that taking address of b harms performance */ + /* TODO - consider optimization search for constants */ + if (TclGetBooleanFromObj(NULL, valuePtr, &b) != TCL_OK) { + TRACE(("\"%.20s\" => ILLEGAL TYPE %s\n", O2S(valuePtr), + (valuePtr->typePtr? valuePtr->typePtr->name : "null"))); + IllegalExprOperandType(interp, pc, valuePtr); + goto gotError; } - objResultPtr = Tcl_NewBignumObj(&bigResult); - TRACE(("%s\n", O2S(objResultPtr))); - NEXT_INST_F(1, 2, 1); + /* TODO: Consider peephole opt. */ + objResultPtr = TCONST(!b); + NEXT_INST_F(1, 1, 1); } - case INST_BITOR: - case INST_BITXOR: - case INST_BITAND: - value2Ptr = OBJ_AT_TOS; - valuePtr = OBJ_UNDER_TOS; + 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. + */ - TRESULT = GetNumberFromObj(NULL, valuePtr, &ptr1, &type1); - if ((TRESULT != TCL_OK) - || (type1 == TCL_NUMBER_NAN) - || (type1 == TCL_NUMBER_DOUBLE)) { - TRACE(("%.20s %.20s => ILLEGAL 1st TYPE %s\n", O2S(valuePtr), - O2S(value2Ptr), (valuePtr->typePtr? - valuePtr->typePtr->name : "null"))); + TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(valuePtr), + (valuePtr->typePtr? valuePtr->typePtr->name : "null"))); IllegalExprOperandType(interp, pc, valuePtr); goto gotError; } - TRESULT = GetNumberFromObj(NULL, value2Ptr, &ptr2, &type2); - if ((TRESULT != TCL_OK) || (type2 == TCL_NUMBER_NAN) - || (type2 == TCL_NUMBER_DOUBLE)) { - TRACE(("%.20s %.20s => ILLEGAL 2nd TYPE %s\n", O2S(valuePtr), - O2S(value2Ptr), (value2Ptr->typePtr? - value2Ptr->typePtr->name : "null"))); - IllegalExprOperandType(interp, pc, value2Ptr); + if (type1 == TCL_NUMBER_LONG) { + l1 = *((const long *) ptr1); + if (Tcl_IsShared(valuePtr)) { + TclNewLongObj(objResultPtr, ~l1); + NEXT_INST_F(1, 1, 1); + } + TclSetLongObj(valuePtr, ~l1); + NEXT_INST_F(1, 0, 0); + } + objResultPtr = ExecuteExtendedUnaryMathOp(*pc, valuePtr); + if (objResultPtr != NULL) { + NEXT_INST_F(1, 1, 1); + } else { + NEXT_INST_F(1, 0, 0); + } + + case INST_UMINUS: + valuePtr = OBJ_AT_TOS; + if ((GetNumberFromObj(NULL, valuePtr, &ptr1, &type1) != TCL_OK) + || IsErroringNaNType(type1)) { + TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(valuePtr), + (valuePtr->typePtr? valuePtr->typePtr->name : "null"))); + IllegalExprOperandType(interp, pc, valuePtr); goto gotError; } + switch (type1) { + case TCL_NUMBER_NAN: + /* -NaN => NaN */ + NEXT_INST_F(1, 0, 0); + case TCL_NUMBER_LONG: + l1 = *((const long *) ptr1); + if (l1 != LONG_MIN) { + if (Tcl_IsShared(valuePtr)) { + TclNewLongObj(objResultPtr, -l1); + NEXT_INST_F(1, 1, 1); + } + TclSetLongObj(valuePtr, -l1); + NEXT_INST_F(1, 0, 0); + } + /* FALLTHROUGH */ + } + objResultPtr = ExecuteExtendedUnaryMathOp(*pc, valuePtr); + if (objResultPtr != NULL) { + NEXT_INST_F(1, 1, 1); + } else { + NEXT_INST_F(1, 0, 0); + } - if ((type1 == TCL_NUMBER_BIG) || (type2 == TCL_NUMBER_BIG)) { - mp_int *First, *Second; - int numPos; + case INST_UPLUS: + 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. + */ - Tcl_TakeBignumFromObj(NULL, valuePtr, &big1); - Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2); + valuePtr = OBJ_AT_TOS; - /* - * Count how many positive arguments we have. If only one of the - * arguments is negative, store it in 'Second'. - */ + if (GetNumberFromObj(NULL, valuePtr, &ptr1, &type1) != TCL_OK) { + if (*pc == INST_UPLUS) { + /* + * ... +$NonNumeric => raise an error. + */ - 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); + TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(valuePtr), + (valuePtr->typePtr? valuePtr->typePtr->name:"null"))); + IllegalExprOperandType(interp, pc, valuePtr); + goto gotError; } - 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 - */ + /* ... TryConvertToNumeric($NonNumeric) is acceptable */ + TRACE(("\"%.20s\" => not numeric\n", O2S(valuePtr))); + NEXT_INST_F(1, 0, 0); + } + if (IsErroringNaNType(type1)) { + if (*pc == INST_UPLUS) { + /* + * ... +$NonNumeric => raise an error. + */ - 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; + TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(valuePtr), + (valuePtr->typePtr? valuePtr->typePtr->name:"null"))); + IllegalExprOperandType(interp, pc, valuePtr); + } else { + /* + * Numeric conversion of NaN -> error. + */ - case INST_BITOR: - switch (numPos) { - case 2: - /* - * Both arguments positive, base case. - */ + TRACE(("\"%.20s\" => IEEE FLOATING PT ERROR\n", + O2S(objResultPtr))); + TclExprFloatError(interp, *((const double *) ptr1)); + } + goto gotError; + } - 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 - */ + /* + * Ensure that the numeric value has a string rep the same as the + * formatted version of its internal rep. This is used, e.g., to make + * sure that "expr {0001}" yields "1", not "0001". We implement this + * by _discarding_ the string rep since we know it will be + * regenerated, if needed later, by formatting the internal rep's + * value. + */ - 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 - */ + if (valuePtr->bytes == NULL) { + TRACE(("\"%.20s\" => numeric, same Tcl_Obj\n", O2S(valuePtr))); + NEXT_INST_F(1, 0, 0); + } + if (Tcl_IsShared(valuePtr)) { + /* + * Here we do some surgery within the Tcl_Obj internals. We want + * to copy the intrep, but not the string, so we temporarily hide + * the string so we do not copy it. + */ - 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; + char *savedString = valuePtr->bytes; - case INST_BITXOR: - switch (numPos) { - case 2: - /* - * Both arguments positive, base case. - */ + valuePtr->bytes = NULL; + objResultPtr = Tcl_DuplicateObj(valuePtr); + valuePtr->bytes = savedString; + TRACE(("\"%.20s\" => numeric, new Tcl_Obj\n", O2S(valuePtr))); + NEXT_INST_F(1, 1, 1); + } + TclInvalidateStringRep(valuePtr); + TRACE(("\"%.20s\" => numeric, same Tcl_Obj\n", O2S(valuePtr))); + NEXT_INST_F(1, 0, 0); + } - mp_xor(First, Second, &bigResult); - break; - case 1: - /* - * First is positive; second negative: - * P^N = ~(P^~N) = -(P^(-N-1))-1 - */ + /* + * End of numeric operator instructions. + * ----------------------------------------------------------------- + */ - 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) - */ + case INST_BREAK: + /* + DECACHE_STACK_INFO(); + Tcl_ResetResult(interp); + CACHE_STACK_INFO(); + */ + TRESULT = TCL_BREAK; + cleanup = 0; + goto processExceptionReturn; - 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; - } + case INST_CONTINUE: + /* + DECACHE_STACK_INFO(); + Tcl_ResetResult(interp); + CACHE_STACK_INFO(); + */ + TRESULT = TCL_CONTINUE; + cleanup = 0; + goto processExceptionReturn; - 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); - } + { + 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; -#ifndef NO_WIDE_TYPE - if ((type1 == TCL_NUMBER_WIDE) || (type2 == TCL_NUMBER_WIDE)) { - TclGetWideIntFromObj(NULL, valuePtr, &w1); - TclGetWideIntFromObj(NULL, value2Ptr, &w2); + case INST_FOREACH_START4: + /* + * Initialize the temporary local var that holds the count of the + * number of iterations of the loop body to -1. + */ - switch (*pc) { - case INST_BITAND: - wResult = w1 & w2; - break; - case INST_BITOR: - wResult = w1 | w2; - break; - case INST_BITXOR: - wResult = w1 ^ w2; - break; - default: - /* Unused, here to silence compiler warning. */ - wResult = 0; - } + opnd = TclGetUInt4AtPtr(pc+1); + infoPtr = codePtr->auxDataArrayPtr[opnd].clientData; + iterTmpIndex = infoPtr->loopCtTemp; + iterVarPtr = LOCAL(iterTmpIndex); + oldValuePtr = iterVarPtr->value.objPtr; - TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); - if (Tcl_IsShared(valuePtr)) { - objResultPtr = Tcl_NewWideIntObj(wResult); - TRACE(("%s\n", O2S(objResultPtr))); - NEXT_INST_F(1, 2, 1); - } - Tcl_SetWideIntObj(valuePtr, wResult); - TRACE(("%s\n", O2S(valuePtr))); - NEXT_INST_F(1, 1, 0); + if (oldValuePtr == NULL) { + TclNewLongObj(iterVarPtr->value.objPtr, -1); + Tcl_IncrRefCount(iterVarPtr->value.objPtr); + } else { + TclSetLongObj(oldValuePtr, -1); } + TRACE(("%u => loop iter count temp %d\n", opnd, iterTmpIndex)); + +#ifndef TCL_COMPILE_DEBUG + /* + * Remark that the compiler ALWAYS sets INST_FOREACH_STEP4 immediately + * after INST_FOREACH_START4 - let us just fall through instead of + * jumping back to the top. + */ + + pc += 5; + TCL_DTRACE_INST_NEXT(); +#else + NEXT_INST_F(5, 0, 0); #endif - l1 = *((const long *)ptr1); - l2 = *((const long *)ptr2); - switch (*pc) { - case INST_BITAND: - lResult = l1 & l2; - break; - case INST_BITOR: - lResult = l1 | l2; - break; - case INST_BITXOR: - lResult = l1 ^ l2; - break; - default: - /* Unused, here to silence compiler warning. */ - lResult = 0; - } + 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. + */ - 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); + opnd = TclGetUInt4AtPtr(pc+1); + infoPtr = codePtr->auxDataArrayPtr[opnd].clientData; + numLists = infoPtr->numLists; - case INST_EXPON: - case INST_ADD: - case INST_SUB: - case INST_DIV: - case INST_MULT: - value2Ptr = OBJ_AT_TOS; - valuePtr = OBJ_UNDER_TOS; + /* + * Increment the temp holding the loop iteration number. + */ - TRESULT = GetNumberFromObj(NULL, valuePtr, &ptr1, &type1); - if ((TRESULT != TCL_OK) || IsErroringNaNType(type1)) { - TRACE(("%.20s %.20s => ILLEGAL 1st TYPE %s\n", - O2S(value2Ptr), O2S(valuePtr), - (valuePtr->typePtr? valuePtr->typePtr->name: "null"))); - IllegalExprOperandType(interp, pc, valuePtr); - goto gotError; - } + iterVarPtr = LOCAL(infoPtr->loopCtTemp); + valuePtr = iterVarPtr->value.objPtr; + iterNum = valuePtr->internalRep.longValue + 1; + TclSetLongObj(valuePtr, iterNum); -#ifdef ACCEPT_NAN - if (type1 == TCL_NUMBER_NAN) { - /* - * NaN first argument -> result is also NaN. - */ + /* + * Check whether all value lists are exhausted and we should stop the + * loop. + */ - NEXT_INST_F(1, 1, 0); - } -#endif + continueLoop = 0; + listTmpIndex = infoPtr->firstValueTemp; + for (i = 0; i < numLists; i++) { + varListPtr = infoPtr->varLists[i]; + numVars = varListPtr->numVars; - TRESULT = GetNumberFromObj(NULL, value2Ptr, &ptr2, &type2); - if ((TRESULT != TCL_OK) || IsErroringNaNType(type2)) { - TRACE(("%.20s %.20s => ILLEGAL 2nd TYPE %s\n", - O2S(value2Ptr), O2S(valuePtr), - (value2Ptr->typePtr? value2Ptr->typePtr->name: "null"))); - IllegalExprOperandType(interp, pc, value2Ptr); - goto gotError; + listVarPtr = LOCAL(listTmpIndex); + listPtr = listVarPtr->value.objPtr; + if (TclListObjLength(interp, listPtr, &listLen) != TCL_OK) { + TRACE_WITH_OBJ(("%u => ERROR converting list %ld, \"%s\": ", + opnd, i, O2S(listPtr)), Tcl_GetObjResult(interp)); + goto gotError; + } + if (listLen > iterNum * numVars) { + continueLoop = 1; + } + listTmpIndex++; } -#ifdef ACCEPT_NAN - if (type2 == TCL_NUMBER_NAN) { - /* - * NaN second argument -> result is also NaN. - */ - - objResultPtr = value2Ptr; - NEXT_INST_F(1, 2, 1); - } -#endif + /* + * If some var in some var list still has a remaining list element + * iterate one more time. Assign to var the next element from its + * value list. We already checked above that each list temp holds a + * valid list object (by calling Tcl_ListObjLength), but cannot rely + * on that check remaining valid: one list could have been shimmered + * as a side effect of setting a traced variable. + */ - if ((type1 == TCL_NUMBER_DOUBLE) || (type2 == TCL_NUMBER_DOUBLE)) { - /* - * At least one of the values is floating-point, so perform - * floating point calculations. - */ + if (continueLoop) { + listTmpIndex = infoPtr->firstValueTemp; + for (i = 0; i < numLists; i++) { + varListPtr = infoPtr->varLists[i]; + numVars = varListPtr->numVars; - Tcl_GetDoubleFromObj(NULL, valuePtr, &d1); - Tcl_GetDoubleFromObj(NULL, value2Ptr, &d2); + listVarPtr = LOCAL(listTmpIndex); + listPtr = TclListObjCopy(NULL, listVarPtr->value.objPtr); + TclListObjGetElements(interp, listPtr, &listLen, &elements); - 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 - /* - * 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. - */ + valIndex = (iterNum * numVars); + for (j = 0; j < numVars; j++) { + if (valIndex >= listLen) { + TclNewObj(valuePtr); + } else { + valuePtr = elements[valIndex]; + } - 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; + varIndex = varListPtr->varIndexes[j]; + varPtr = LOCAL(varIndex); + while (TclIsVarLink(varPtr)) { + varPtr = varPtr->value.linkPtr; + } + if (TclIsVarDirectWritable(varPtr)) { + value2Ptr = varPtr->value.objPtr; + if (valuePtr != value2Ptr) { + if (value2Ptr != NULL) { + TclDecrRefCount(value2Ptr); + } + varPtr->value.objPtr = valuePtr; + Tcl_IncrRefCount(valuePtr); + } + } else { + DECACHE_STACK_INFO(); + if (TclPtrSetVar(interp, varPtr, NULL, NULL, NULL, + valuePtr, TCL_LEAVE_ERR_MSG, varIndex)==NULL){ + CACHE_STACK_INFO(); + TRACE_WITH_OBJ(( + "%u => ERROR init. index temp %d: ", + opnd,varIndex), Tcl_GetObjResult(interp)); + TclDecrRefCount(listPtr); + goto gotError; + } + CACHE_STACK_INFO(); + } + valIndex++; } - 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))); - TclExprFloatError(interp, dResult); - goto gotError; - } -#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); + TclDecrRefCount(listPtr); + listTmpIndex++; } - TclSetDoubleObj(valuePtr, dResult); - TRACE(("%s\n", O2S(valuePtr))); - NEXT_INST_F(1, 1, 0); } + TRACE(("%u => %d lists, iter %d, %s loop\n", opnd, numLists, + iterNum, (continueLoop? "continue" : "exit"))); - if ((sizeof(long) >= 2*sizeof(int)) && (*pc == INST_MULT) - && (type1 == TCL_NUMBER_LONG) && (type2 == TCL_NUMBER_LONG)) { - l1 = *((const long *)ptr1); - l2 = *((const long *)ptr2); + /* + * Run-time peep-hole optimisation: the compiler ALWAYS follows + * INST_FOREACH_STEP4 with an INST_JUMP_FALSE. We just skip that + * instruction and jump direct from here. + */ - if ((l1 <= INT_MAX) && (l1 >= INT_MIN) - && (l2 <= INT_MAX) && (l2 >= INT_MIN)) { - 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); - } + pc += 5; + if (*pc == INST_JUMP_FALSE1) { + NEXT_INST_F((continueLoop? 2 : TclGetInt1AtPtr(pc+1)), 0, 0); + } else { + NEXT_INST_F((continueLoop? 5 : TclGetInt4AtPtr(pc+1)), 0, 0); } + } - if ((sizeof(Tcl_WideInt) >= 2*sizeof(long)) && (*pc == INST_MULT) - && (type1 == TCL_NUMBER_LONG) && (type2 == TCL_NUMBER_LONG)) { - TclGetWideIntFromObj(NULL, valuePtr, &w1); - TclGetWideIntFromObj(NULL, value2Ptr, &w2); + case INST_BEGIN_CATCH4: + /* + * Record start of the catch command with exception range index equal + * to the operand. Push the current stack depth onto the special catch + * stack. + */ - wResult = w1 * w2; + *(++catchTop) = CURR_DEPTH; + TRACE(("%u => catchTop=%d, stackTop=%d\n", + TclGetUInt4AtPtr(pc+1), (int) (catchTop - initCatchTop - 1), + (int) CURR_DEPTH)); + NEXT_INST_F(5, 0, 0); - TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); - if (Tcl_IsShared(valuePtr)) { - objResultPtr = Tcl_NewWideIntObj(wResult); - TRACE(("%s\n", O2S(objResultPtr))); - NEXT_INST_F(1, 2, 1); - } - Tcl_SetWideIntObj(valuePtr, wResult); - TRACE(("%s\n", O2S(valuePtr))); - NEXT_INST_F(1, 1, 0); - } + case INST_END_CATCH: + catchTop--; + Tcl_ResetResult(interp); + TRESULT = TCL_OK; + TRACE(("=> catchTop=%d\n", (int) (catchTop - initCatchTop - 1))); + NEXT_INST_F(1, 0, 0); - /* TODO: Attempts to re-use unshared operands on stack. */ - if (*pc == INST_EXPON) { - int oddExponent = 0, negativeExponent = 0; - unsigned short base; + case INST_PUSH_RESULT: + objResultPtr = Tcl_GetObjResult(interp); + TRACE_WITH_OBJ(("=> "), objResultPtr); - l1 = l2 = 0; - if (type2 == TCL_NUMBER_LONG) { - l2 = *((const long *) ptr2); - if (l2 == 0) { - /* - * Anything to the zero power is 1. - */ + /* + * See the comments at INST_INVOKE_STK + */ - objResultPtr = TCONST(1); - NEXT_INST_F(1, 2, 1); - } else if (l2 == 1) { - /* - * Anything to the first power is itself - */ - NEXT_INST_F(1, 1, 0); - } - } + TclNewObj(objPtr); + Tcl_IncrRefCount(objPtr); + iPtr->objResultPtr = objPtr; + NEXT_INST_F(1, 0, -1); - switch (type2) { - case TCL_NUMBER_LONG: { - negativeExponent = (l2 < 0); - oddExponent = (int) (l2 & 1); - break; - } -#ifndef NO_WIDE_TYPE - case TCL_NUMBER_WIDE: - w2 = *((const Tcl_WideInt *)ptr2); - negativeExponent = (w2 < 0); - oddExponent = (int) (w2 & (Tcl_WideInt)1); - break; -#endif - case TCL_NUMBER_BIG: - Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2); - negativeExponent = (mp_cmp_d(&big2, 0) == MP_LT); - mp_mod_2d(&big2, 1, &big2); - oddExponent = !mp_iszero(&big2); - mp_clear(&big2); - break; - } + case INST_PUSH_RETURN_CODE: + TclNewIntObj(objResultPtr, TRESULT); + TRACE(("=> %u\n", TRESULT)); + NEXT_INST_F(1, 0, 1); - 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. - */ + case INST_PUSH_RETURN_OPTIONS: + objResultPtr = Tcl_GetReturnOptions(interp, TRESULT); + TRACE_WITH_OBJ(("=> "), objResultPtr); + NEXT_INST_F(1, 0, 1); - TRACE(("%s %s => EXPONENT OF ZERO\n", O2S(valuePtr), - O2S(value2Ptr))); - goto exponOfZero; - case -1: - if (oddExponent) { - TclNewIntObj(objResultPtr, -1); - } else { - objResultPtr = TCONST(1); - } - NEXT_INST_F(1, 2, 1); - case 1: - /* - * 1 to any power is 1. - */ + case INST_RETURN_CODE_BRANCH: { + int code; - objResultPtr = TCONST(1); - NEXT_INST_F(1, 2, 1); - } - } - - /* - * Integers with magnitude greater than 1 raise to a negative - * power yield the answer zero (see TIP 123). - */ - - objResultPtr = TCONST(0); - NEXT_INST_F(1, 2, 1); - } - - if (type1 == TCL_NUMBER_LONG) { - switch (l1) { - case 0: - /* - * Zero to a positive power is zero. - */ - - objResultPtr = TCONST(0); - NEXT_INST_F(1, 2, 1); - case 1: - /* - * 1 to any power is 1. - */ + 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); + } - objResultPtr = TCONST(1); - NEXT_INST_F(1, 2, 1); - case -1: - if (oddExponent) { - TclNewIntObj(objResultPtr, -1); - } else { - objResultPtr = TCONST(1); - } - NEXT_INST_F(1, 2, 1); - } - } + /* + * ----------------------------------------------------------------- + * Start of dictionary-related instructions. + */ - /* - * 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. - */ + { + int opnd2, allocateDict, done, i, allocdict; + Tcl_Obj *dictPtr, *statePtr, *keyPtr; + Tcl_Obj *emptyPtr, **keyPtrPtr; + Tcl_DictSearch *searchPtr; + DictUpdateInfo *duiPtr; - if (type2 != TCL_NUMBER_LONG) { - Tcl_SetResult(interp, "exponent too large", TCL_STATIC); + case INST_DICT_GET: + opnd = TclGetUInt4AtPtr(pc+1); + TRACE(("%u => ", opnd)); + dictPtr = OBJ_AT_DEPTH(opnd); + if (opnd > 1) { + dictPtr = TclTraceDictPath(interp, dictPtr, opnd-1, + &OBJ_AT_DEPTH(opnd-1), DICT_PATH_READ); + if (dictPtr == NULL) { + TRACE_WITH_OBJ(( + "%u => ERROR tracing dictionary path into \"%s\": ", + opnd, O2S(OBJ_AT_DEPTH(opnd))), + Tcl_GetObjResult(interp)); goto gotError; } + } + if (Tcl_DictObjGet(interp, dictPtr, OBJ_AT_TOS, + &objResultPtr) == TCL_OK) { + if (objResultPtr) { + TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); + NEXT_INST_V(5, opnd+1, 1); + } + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "key \"", TclGetString(OBJ_AT_TOS), + "\" not known in dictionary", NULL); + TRACE_WITH_OBJ(("%u => ERROR ", opnd), Tcl_GetObjResult(interp)); + } else { + TRACE_WITH_OBJ(( + "%u => ERROR reading leaf dictionary key \"%s\": ", + opnd, O2S(dictPtr)), Tcl_GetObjResult(interp)); + } + goto gotError; - if (type1 == TCL_NUMBER_LONG) { - if (l1 == 2) { - /* - * Reduce small powers of 2 to shifts. - */ - - if ((unsigned long) l2 < CHAR_BIT * sizeof(long) - 1) { - TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); - TclNewLongObj(objResultPtr, (1L << l2)); - TRACE(("%s\n", O2S(objResultPtr))); - NEXT_INST_F(1, 2, 1); - } -#if !defined(TCL_WIDE_INT_IS_LONG) - if ((unsigned long)l2 < CHAR_BIT*sizeof(Tcl_WideInt) - 1){ - TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); - objResultPtr = - Tcl_NewWideIntObj(((Tcl_WideInt) 1) << l2); - TRACE(("%s\n", O2S(objResultPtr))); - NEXT_INST_F(1, 2, 1); - } -#endif - goto overflow; - } - if (l1 == -2) { - int signum = oddExponent ? -1 : 1; - - /* - * Reduce small powers of 2 to shifts. - */ - - if ((unsigned long) l2 < CHAR_BIT * sizeof(long) - 1) { - TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); - TclNewLongObj(objResultPtr, signum * (1L << l2)); - TRACE(("%s\n", O2S(objResultPtr))); - NEXT_INST_F(1, 2, 1); - } -#if !defined(TCL_WIDE_INT_IS_LONG) - if ((unsigned long)l2 < CHAR_BIT*sizeof(Tcl_WideInt) - 1){ - TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); - objResultPtr = Tcl_NewWideIntObj( - signum * (((Tcl_WideInt) 1) << l2)); - TRACE(("%s\n", O2S(objResultPtr))); - NEXT_INST_F(1, 2, 1); - } -#endif - goto overflow; - } -#if (LONG_MAX == 0x7fffffff) - if (l2 - 2 < (long)MaxBase32Size - && l1 <= MaxBase32[l2 - 2] - && l1 >= -MaxBase32[l2 - 2]) { - /* - * Small powers of 32-bit integers. - */ - - 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)) { - 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. - */ + case INST_DICT_SET: + case INST_DICT_UNSET: + case INST_DICT_INCR_IMM: + opnd = TclGetUInt4AtPtr(pc+1); + opnd2 = TclGetUInt4AtPtr(pc+5); - 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)) { - 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. - */ + varPtr = LOCAL(opnd2); + while (TclIsVarLink(varPtr)) { + varPtr = varPtr->value.linkPtr; + } + TRACE(("%u %u => ", opnd, opnd2)); + if (TclIsVarDirectReadable(varPtr)) { + dictPtr = varPtr->value.objPtr; + } else { + DECACHE_STACK_INFO(); + dictPtr = TclPtrGetVar(interp, varPtr, NULL,NULL,NULL, 0, opnd2); + CACHE_STACK_INFO(); + } + if (dictPtr == NULL) { + TclNewObj(dictPtr); + allocateDict = 1; + } else { + allocateDict = Tcl_IsShared(dictPtr); + if (allocateDict) { + dictPtr = Tcl_DuplicateObj(dictPtr); + } + } - lResult = (oddExponent) ? - -Exp32Value[base] : Exp32Value[base]; - 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 + switch (*pc) { + case INST_DICT_SET: + cleanup = opnd + 1; + TRESULT = Tcl_DictObjPutKeyList(interp, dictPtr, opnd, + &OBJ_AT_DEPTH(opnd), OBJ_AT_TOS); + break; + case INST_DICT_INCR_IMM: + cleanup = 1; + opnd = TclGetInt4AtPtr(pc+1); + TRESULT = Tcl_DictObjGet(interp, dictPtr, OBJ_AT_TOS, &valuePtr); + if (TRESULT != TCL_OK) { + break; } -#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 + if (valuePtr == NULL) { + Tcl_DictObjPut(NULL, dictPtr, OBJ_AT_TOS,Tcl_NewIntObj(opnd)); } else { - goto overflow; - } - 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; + value2Ptr = Tcl_NewIntObj(opnd); + Tcl_IncrRefCount(value2Ptr); + if (Tcl_IsShared(valuePtr)) { + valuePtr = Tcl_DuplicateObj(valuePtr); + Tcl_DictObjPut(NULL, dictPtr, OBJ_AT_TOS, valuePtr); } - 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)) { - 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); + TRESULT = TclIncrObj(interp, valuePtr, value2Ptr); + if (TRESULT == TCL_OK) { + Tcl_InvalidateStringRep(dictPtr); } + TclDecrRefCount(value2Ptr); } + break; + case INST_DICT_UNSET: + cleanup = opnd; + TRESULT = Tcl_DictObjRemoveKeyList(interp, dictPtr, opnd, + &OBJ_AT_DEPTH(opnd-1)); + break; + default: + cleanup = 0; /* stop compiler warning */ + Tcl_Panic("Should not happen!"); + } - 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]; - TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); - if (Tcl_IsShared(valuePtr)) { - objResultPtr = Tcl_NewWideIntObj(wResult); - TRACE(("%s\n", O2S(objResultPtr))); - NEXT_INST_F(1, 2, 1); - } - Tcl_SetWideIntObj(valuePtr, wResult); - TRACE(("%s\n", O2S(valuePtr))); - NEXT_INST_F(1, 1, 0); - } + if (TRESULT != TCL_OK) { + if (allocateDict) { + TclDecrRefCount(dictPtr); } -#endif - - goto overflow; + TRACE_WITH_OBJ(("%u %u => ERROR updating dictionary: ", + opnd, opnd2), Tcl_GetObjResult(interp)); + goto checkForCatch; } - if ((*pc != INST_MULT) - && (type1 != TCL_NUMBER_BIG) && (type2 != TCL_NUMBER_BIG)) { - 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; - } + if (TclIsVarDirectWritable(varPtr)) { + if (allocateDict) { + value2Ptr = varPtr->value.objPtr; + Tcl_IncrRefCount(dictPtr); + if (value2Ptr != NULL) { + TclDecrRefCount(value2Ptr); } - break; - - case INST_SUB: - wResult = w1 - w2; -#ifndef NO_WIDE_TYPE - if ((type1 == TCL_NUMBER_WIDE) || (type2 == TCL_NUMBER_WIDE)) + varPtr->value.objPtr = dictPtr; + } + objResultPtr = dictPtr; + } else { + Tcl_IncrRefCount(dictPtr); + DECACHE_STACK_INFO(); + objResultPtr = TclPtrSetVar(interp, varPtr, NULL, NULL, NULL, + dictPtr, TCL_LEAVE_ERR_MSG, opnd2); + CACHE_STACK_INFO(); + TclDecrRefCount(dictPtr); + if (objResultPtr == NULL) { + TRACE_APPEND(("ERROR: %.30s\n", + O2S(Tcl_GetObjResult(interp)))); + goto gotError; + } + } +#ifndef TCL_COMPILE_DEBUG + if (*(pc+9) == INST_POP) { + NEXT_INST_V(10, cleanup, 0); + } #endif - { - /* - * Must check for overflow. The macro tests for overflows - * in sums by looking at the sign bits. As we have a - * subtraction here, we are adding -w2. As -w2 could in - * turn overflow, we test with ~w2 instead: it has the - * opposite sign bit to w2 so it does the job. Note that - * the only "bad" case (w2==0) is irrelevant for this - * macro, as in that case w1 and wResult have the same - * sign and there is no overflow anyway. - */ - - if (Overflowing(w1, ~w2, wResult)) { - goto overflow; - } - } - break; - - case INST_DIV: - if (w2 == 0) { - TRACE(("%s %s => DIVIDE BY ZERO\n", - O2S(valuePtr), O2S(value2Ptr))); - goto divideByZero; - } - - /* - * Need a bignum to represent (LLONG_MIN / -1) - */ - - if ((w1 == LLONG_MIN) && (w2 == -1)) { - goto overflow; - } - wResult = w1 / w2; - - /* - * Force Tcl's integer division rules. - * TODO: examine for logic simplification - */ - - if (((wResult < 0) || ((wResult == 0) && - ((w1 < 0 && w2 > 0) || (w1 > 0 && w2 < 0)))) && - ((wResult * w2) != w1)) { - wResult -= 1; - } - break; - default: - /* - * Unused, here to silence compiler warning. - */ + TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); + NEXT_INST_V(9, cleanup, 1); - wResult = 0; + case INST_DICT_APPEND: + case INST_DICT_LAPPEND: + opnd = TclGetUInt4AtPtr(pc+1); + varPtr = LOCAL(opnd); + while (TclIsVarLink(varPtr)) { + varPtr = varPtr->value.linkPtr; + } + TRACE(("%u => ", opnd)); + if (TclIsVarDirectReadable(varPtr)) { + dictPtr = varPtr->value.objPtr; + } else { + DECACHE_STACK_INFO(); + dictPtr = TclPtrGetVar(interp, varPtr, NULL, NULL, NULL, 0, opnd); + CACHE_STACK_INFO(); + } + if (dictPtr == NULL) { + TclNewObj(dictPtr); + allocateDict = 1; + } else { + allocateDict = Tcl_IsShared(dictPtr); + if (allocateDict) { + dictPtr = Tcl_DuplicateObj(dictPtr); } + } - 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); + if (Tcl_DictObjGet(interp, dictPtr, OBJ_UNDER_TOS, + &valuePtr) != TCL_OK) { + if (allocateDict) { + TclDecrRefCount(dictPtr); } - Tcl_SetWideIntObj(valuePtr, wResult); - TRACE(("%s\n", O2S(valuePtr))); - NEXT_INST_F(1, 1, 0); + goto gotError; } - overflow: - TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); - Tcl_TakeBignumFromObj(NULL, valuePtr, &big1); - Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2); - mp_init(&bigResult); + /* + * 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_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; + case INST_DICT_APPEND: + if (valuePtr == NULL) { + Tcl_DictObjPut(NULL, dictPtr, OBJ_UNDER_TOS, OBJ_AT_TOS); + } else if (Tcl_IsShared(valuePtr)) { + valuePtr = Tcl_DuplicateObj(valuePtr); + Tcl_AppendObjToObj(valuePtr, OBJ_AT_TOS); + Tcl_DictObjPut(NULL, dictPtr, OBJ_UNDER_TOS, valuePtr); + } else { + Tcl_AppendObjToObj(valuePtr, OBJ_AT_TOS); } - 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. - */ + break; + case INST_DICT_LAPPEND: + /* + * More complex because list-append can fail. + */ - mp_sub_d(&bigResult, 1, &bigResult); - mp_add(&bigRemainder, &big2, &bigRemainder); + if (valuePtr == NULL) { + Tcl_DictObjPut(NULL, dictPtr, OBJ_UNDER_TOS, + Tcl_NewListObj(1, &OBJ_AT_TOS)); + break; + } else if (Tcl_IsShared(valuePtr)) { + valuePtr = Tcl_DuplicateObj(valuePtr); + if (Tcl_ListObjAppendElement(interp, valuePtr, + OBJ_AT_TOS) != TCL_OK) { + TclDecrRefCount(valuePtr); + if (allocateDict) { + TclDecrRefCount(dictPtr); + } + goto gotError; + } + Tcl_DictObjPut(NULL, dictPtr, OBJ_UNDER_TOS, valuePtr); + } else { + if (Tcl_ListObjAppendElement(interp, valuePtr, + OBJ_AT_TOS) != TCL_OK) { + if (allocateDict) { + TclDecrRefCount(dictPtr); + } + goto gotError; + } } - mp_clear(&bigRemainder); break; - case INST_EXPON: - if (big2.used > 1) { - Tcl_SetResult(interp, "exponent too large", TCL_STATIC); - mp_clear(&big1); - mp_clear(&big2); - mp_clear(&bigResult); + default: + Tcl_Panic("Should not happen!"); + } + + if (TclIsVarDirectWritable(varPtr)) { + if (allocateDict) { + value2Ptr = varPtr->value.objPtr; + Tcl_IncrRefCount(dictPtr); + if (value2Ptr != NULL) { + TclDecrRefCount(value2Ptr); + } + varPtr->value.objPtr = dictPtr; + } + objResultPtr = dictPtr; + } else { + Tcl_IncrRefCount(dictPtr); + DECACHE_STACK_INFO(); + objResultPtr = TclPtrSetVar(interp, varPtr, NULL, NULL, NULL, + dictPtr, TCL_LEAVE_ERR_MSG, opnd); + CACHE_STACK_INFO(); + TclDecrRefCount(dictPtr); + if (objResultPtr == NULL) { + TRACE_APPEND(("ERROR: %.30s\n", + O2S(Tcl_GetObjResult(interp)))); goto gotError; } - 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); +#ifndef TCL_COMPILE_DEBUG + if (*(pc+5) == INST_POP) { + NEXT_INST_F(6, 2, 0); } - Tcl_SetBignumObj(valuePtr, &bigResult); - TRACE(("%s\n", O2S(valuePtr))); - NEXT_INST_F(1, 1, 0); - - case INST_LNOT: { - int b; - - valuePtr = OBJ_AT_TOS; +#endif + TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); + NEXT_INST_F(5, 2, 1); - /* TODO - check claim that taking address of b harms performance */ - /* TODO - consider optimization search for constants */ - if (TclGetBooleanFromObj(NULL, valuePtr, &b) != TCL_OK) { - TRACE(("\"%.20s\" => ILLEGAL TYPE %s\n", O2S(valuePtr), - (valuePtr->typePtr? valuePtr->typePtr->name : "null"))); - IllegalExprOperandType(interp, pc, valuePtr); + case INST_DICT_FIRST: + opnd = TclGetUInt4AtPtr(pc+1); + TRACE(("%u => ", opnd)); + dictPtr = POP_OBJECT(); + searchPtr = (Tcl_DictSearch *) ckalloc(sizeof(Tcl_DictSearch)); + if (Tcl_DictObjFirst(interp, dictPtr, searchPtr, &keyPtr, + &valuePtr, &done) != TCL_OK) { + ckfree((char *) searchPtr); goto gotError; } - /* TODO: Consider peephole opt. */ - objResultPtr = TCONST(!b); - NEXT_INST_F(1, 1, 1); - } - - case INST_BITNOT: - valuePtr = OBJ_AT_TOS; - TRESULT = GetNumberFromObj(NULL, valuePtr, &ptr1, &type1); - if ((TRESULT != TCL_OK) || (type1 == TCL_NUMBER_NAN) - || (type1 == TCL_NUMBER_DOUBLE)) { + TclNewObj(statePtr); + statePtr->typePtr = &dictIteratorType; + statePtr->internalRep.twoPtrValue.ptr1 = searchPtr; + statePtr->internalRep.twoPtrValue.ptr2 = dictPtr; + varPtr = LOCAL(opnd); + if (varPtr->value.objPtr) { + if (varPtr->value.objPtr->typePtr == &dictIteratorType) { + Tcl_Panic("mis-issued dictFirst!"); + } + TclDecrRefCount(varPtr->value.objPtr); + } + varPtr->value.objPtr = statePtr; + Tcl_IncrRefCount(statePtr); + goto pushDictIteratorResult; + + case INST_DICT_NEXT: + opnd = TclGetUInt4AtPtr(pc+1); + TRACE(("%u => ", opnd)); + statePtr = (*LOCAL(opnd)).value.objPtr; + if (statePtr == NULL || statePtr->typePtr != &dictIteratorType) { + Tcl_Panic("mis-issued dictNext!"); + } + searchPtr = statePtr->internalRep.twoPtrValue.ptr1; + Tcl_DictObjNext(searchPtr, &keyPtr, &valuePtr, &done); + pushDictIteratorResult: + if (done) { + TclNewObj(emptyPtr); + PUSH_OBJECT(emptyPtr); + PUSH_OBJECT(emptyPtr); + } else { + PUSH_OBJECT(valuePtr); + PUSH_OBJECT(keyPtr); + } + TRACE_APPEND(("\"%.30s\" \"%.30s\" %d", + O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS), done)); + objResultPtr = TCONST(done); + /* TODO: consider opt like INST_FOREACH_STEP4 */ + NEXT_INST_F(5, 0, 1); + + case INST_DICT_DONE: + opnd = TclGetUInt4AtPtr(pc+1); + TRACE(("%u => ", opnd)); + statePtr = (*LOCAL(opnd)).value.objPtr; + if (statePtr == NULL) { + Tcl_Panic("mis-issued dictDone!"); + } + + if (statePtr->typePtr == &dictIteratorType) { /* - * ... ~$NonInteger => raise an error. + * First kill the search, and then release the reference to the + * dictionary that we were holding. */ - TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(valuePtr), - (valuePtr->typePtr? valuePtr->typePtr->name : "null"))); - IllegalExprOperandType(interp, pc, valuePtr); - goto gotError; + searchPtr = statePtr->internalRep.twoPtrValue.ptr1; + Tcl_DictObjDone(searchPtr); + ckfree((char *) searchPtr); + + dictPtr = statePtr->internalRep.twoPtrValue.ptr2; + TclDecrRefCount(dictPtr); + + /* + * Set the internal variable to an empty object to signify that we + * don't hold an iterator. + */ + + TclDecrRefCount(statePtr); + TclNewObj(emptyPtr); + (*LOCAL(opnd)).value.objPtr = emptyPtr; + Tcl_IncrRefCount(emptyPtr); } - if (type1 == TCL_NUMBER_LONG) { - l1 = *((const long *) ptr1); - if (Tcl_IsShared(valuePtr)) { - TclNewLongObj(objResultPtr, ~l1); - NEXT_INST_F(1, 1, 1); - } - TclSetLongObj(valuePtr, ~l1); - NEXT_INST_F(1, 0, 0); + NEXT_INST_F(5, 0, 0); + + case INST_DICT_UPDATE_START: + opnd = TclGetUInt4AtPtr(pc+1); + opnd2 = TclGetUInt4AtPtr(pc+5); + varPtr = LOCAL(opnd); + duiPtr = codePtr->auxDataArrayPtr[opnd2].clientData; + while (TclIsVarLink(varPtr)) { + varPtr = varPtr->value.linkPtr; } -#ifndef NO_WIDE_TYPE - if (type1 == TCL_NUMBER_WIDE) { - w1 = *((const Tcl_WideInt *) ptr1); - if (Tcl_IsShared(valuePtr)) { - objResultPtr = Tcl_NewWideIntObj(~w1); - NEXT_INST_F(1, 1, 1); + TRACE(("%u => ", opnd)); + if (TclIsVarDirectReadable(varPtr)) { + dictPtr = varPtr->value.objPtr; + } else { + DECACHE_STACK_INFO(); + dictPtr = TclPtrGetVar(interp, varPtr, NULL, NULL, NULL, + TCL_LEAVE_ERR_MSG, opnd); + CACHE_STACK_INFO(); + if (dictPtr == NULL) { + goto gotError; } - Tcl_SetWideIntObj(valuePtr, ~w1); - NEXT_INST_F(1, 0, 0); } -#endif - Tcl_TakeBignumFromObj(NULL, valuePtr, &big1); - /* ~a = - a - 1 */ - mp_neg(&big1, &big1); - mp_sub_d(&big1, 1, &big1); - if (Tcl_IsShared(valuePtr)) { - objResultPtr = Tcl_NewBignumObj(&big1); - NEXT_INST_F(1, 1, 1); + if (TclListObjGetElements(interp, OBJ_AT_TOS, &length, + &keyPtrPtr) != TCL_OK) { + goto gotError; } - Tcl_SetBignumObj(valuePtr, &big1); - NEXT_INST_F(1, 0, 0); + if (length != duiPtr->length) { + Tcl_Panic("dictUpdateStart argument length mismatch"); + } + for (i=0 ; ivarIndices[i]); + while (TclIsVarLink(varPtr)) { + varPtr = varPtr->value.linkPtr; + } + DECACHE_STACK_INFO(); + if (valuePtr == NULL) { + TclObjUnsetVar2(interp, + localName(iPtr->varFramePtr, duiPtr->varIndices[i]), + NULL, 0); + } else if (TclPtrSetVar(interp, varPtr, NULL, NULL, NULL, + valuePtr, TCL_LEAVE_ERR_MSG, + duiPtr->varIndices[i]) == NULL) { + CACHE_STACK_INFO(); + goto gotError; + } + CACHE_STACK_INFO(); + } + NEXT_INST_F(9, 0, 0); - case INST_UMINUS: - valuePtr = OBJ_AT_TOS; - TRESULT = GetNumberFromObj(NULL, valuePtr, &ptr1, &type1); - if ((TRESULT != TCL_OK) || IsErroringNaNType(type1)) { - TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(valuePtr), - (valuePtr->typePtr? valuePtr->typePtr->name : "null"))); - IllegalExprOperandType(interp, pc, valuePtr); + case INST_DICT_UPDATE_END: + opnd = TclGetUInt4AtPtr(pc+1); + opnd2 = TclGetUInt4AtPtr(pc+5); + varPtr = LOCAL(opnd); + duiPtr = codePtr->auxDataArrayPtr[opnd2].clientData; + while (TclIsVarLink(varPtr)) { + varPtr = varPtr->value.linkPtr; + } + TRACE(("%u => ", opnd)); + if (TclIsVarDirectReadable(varPtr)) { + dictPtr = varPtr->value.objPtr; + } else { + DECACHE_STACK_INFO(); + dictPtr = TclPtrGetVar(interp, varPtr, NULL, NULL, NULL, 0, opnd); + CACHE_STACK_INFO(); + } + if (dictPtr == NULL) { + NEXT_INST_F(9, 1, 0); + } + if (Tcl_DictObjSize(interp, dictPtr, &length) != TCL_OK + || TclListObjGetElements(interp, OBJ_AT_TOS, &length, + &keyPtrPtr) != TCL_OK) { goto gotError; } - switch (type1) { - case TCL_NUMBER_DOUBLE: - if (Tcl_IsShared(valuePtr)) { - TclNewDoubleObj(objResultPtr, -(*((const double *) ptr1))); - NEXT_INST_F(1, 1, 1); + allocdict = Tcl_IsShared(dictPtr); + if (allocdict) { + dictPtr = Tcl_DuplicateObj(dictPtr); + } + for (i=0 ; ivarIndices[i]); + + while (TclIsVarLink(var2Ptr)) { + var2Ptr = var2Ptr->value.linkPtr; } - d1 = *((const double *) ptr1); - TclSetDoubleObj(valuePtr, -d1); - NEXT_INST_F(1, 0, 0); - case TCL_NUMBER_LONG: - l1 = *((const long *) ptr1); - if (l1 != LONG_MIN) { - if (Tcl_IsShared(valuePtr)) { - TclNewLongObj(objResultPtr, -l1); - NEXT_INST_F(1, 1, 1); - } - TclSetLongObj(valuePtr, -l1); - NEXT_INST_F(1, 0, 0); + if (TclIsVarDirectReadable(var2Ptr)) { + valuePtr = var2Ptr->value.objPtr; + } else { + DECACHE_STACK_INFO(); + valuePtr = TclPtrGetVar(interp, var2Ptr, NULL, NULL, NULL, 0, + duiPtr->varIndices[i]); + CACHE_STACK_INFO(); } - /* FALLTHROUGH */ -#ifndef NO_WIDE_TYPE - case TCL_NUMBER_WIDE: - if (type1 == TCL_NUMBER_LONG) { - w1 = (Tcl_WideInt)(*((const long *) ptr1)); + if (valuePtr == NULL) { + Tcl_DictObjRemove(interp, dictPtr, keyPtrPtr[i]); + } else if (dictPtr == valuePtr) { + Tcl_DictObjPut(interp, dictPtr, keyPtrPtr[i], + Tcl_DuplicateObj(valuePtr)); } else { - w1 = *((const Tcl_WideInt *) ptr1); + Tcl_DictObjPut(interp, dictPtr, keyPtrPtr[i], valuePtr); } - if (w1 != LLONG_MIN) { - if (Tcl_IsShared(valuePtr)) { - objResultPtr = Tcl_NewWideIntObj(-w1); - NEXT_INST_F(1, 1, 1); + } + if (TclIsVarDirectWritable(varPtr)) { + Tcl_IncrRefCount(dictPtr); + TclDecrRefCount(varPtr->value.objPtr); + varPtr->value.objPtr = dictPtr; + } else { + DECACHE_STACK_INFO(); + objResultPtr = TclPtrSetVar(interp, varPtr, NULL, NULL, NULL, + dictPtr, TCL_LEAVE_ERR_MSG, opnd); + CACHE_STACK_INFO(); + if (objResultPtr == NULL) { + if (allocdict) { + TclDecrRefCount(dictPtr); } - Tcl_SetWideIntObj(valuePtr, -w1); - NEXT_INST_F(1, 0, 0); - } - /* FALLTHROUGH */ -#endif - case TCL_NUMBER_BIG: - switch (type1) { -#ifdef NO_WIDE_TYPE - case TCL_NUMBER_LONG: - TclBNInitBignumFromLong(&big1, *(const long *) ptr1); - break; -#else - case TCL_NUMBER_WIDE: - TclBNInitBignumFromWideInt(&big1, *(const Tcl_WideInt *)ptr1); - break; -#endif - case TCL_NUMBER_BIG: - Tcl_TakeBignumFromObj(NULL, valuePtr, &big1); - } - mp_neg(&big1, &big1); - if (Tcl_IsShared(valuePtr)) { - objResultPtr = Tcl_NewBignumObj(&big1); - NEXT_INST_F(1, 1, 1); + goto gotError; } - Tcl_SetBignumObj(valuePtr, &big1); - NEXT_INST_F(1, 0, 0); - case TCL_NUMBER_NAN: - /* -NaN => NaN */ - NEXT_INST_F(1, 0, 0); } + NEXT_INST_F(9, 1, 0); + } - case INST_UPLUS: - case INST_TRY_CVT_TO_NUMERIC: - /* - * Try to convert the topmost stack object to numeric object. This is - * done in order to support [expr]'s policy of interpreting operands - * if at all possible as numbers first, then strings. - */ - - valuePtr = OBJ_AT_TOS; + /* + * End of dictionary-related instructions. + * ----------------------------------------------------------------- + */ - if (GetNumberFromObj(NULL, valuePtr, &ptr1, &type1) != TCL_OK) { - if (*pc == INST_UPLUS) { - /* - * ... +$NonNumeric => raise an error. - */ - - TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(valuePtr), - (valuePtr->typePtr? valuePtr->typePtr->name:"null"))); - IllegalExprOperandType(interp, pc, valuePtr); - goto gotError; - } - - /* ... TryConvertToNumeric($NonNumeric) is acceptable */ - TRACE(("\"%.20s\" => not numeric\n", O2S(valuePtr))); - NEXT_INST_F(1, 0, 0); - } - if (IsErroringNaNType(type1)) { - if (*pc == INST_UPLUS) { - /* - * ... +$NonNumeric => raise an error. - */ + default: + Tcl_Panic("TclExecuteByteCode: unrecognized opCode %u", *pc); + } /* end of switch on opCode */ - TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(valuePtr), - (valuePtr->typePtr? valuePtr->typePtr->name:"null"))); - IllegalExprOperandType(interp, pc, valuePtr); - } else { - /* - * Numeric conversion of NaN -> error. - */ + /* + * Block for variables needed to process exception returns. + */ - TRACE(("\"%.20s\" => IEEE FLOATING PT ERROR\n", - O2S(objResultPtr))); - TclExprFloatError(interp, *((const double *) ptr1)); - } - goto gotError; - } + { + ExceptionRange *rangePtr; + /* Points to closest loop or catch exception + * range enclosing the pc. Used by various + * instructions and processCatch to process + * break, continue, and errors. */ + const char *bytes; /* - * Ensure that the numeric value has a string rep the same as the - * formatted version of its internal rep. This is used, e.g., to make - * sure that "expr {0001}" yields "1", not "0001". We implement this - * by _discarding_ the string rep since we know it will be - * regenerated, if needed later, by formatting the internal rep's - * value. + * An external evaluation (INST_INVOKE or INST_EVAL) returned + * something different from TCL_OK, or else INST_BREAK or + * INST_CONTINUE were called. */ - if (valuePtr->bytes == NULL) { - TRACE(("\"%.20s\" => numeric, same Tcl_Obj\n", O2S(valuePtr))); - NEXT_INST_F(1, 0, 0); - } - if (Tcl_IsShared(valuePtr)) { + processExceptionReturn: +#if TCL_COMPILE_DEBUG + switch (*pc) { + case INST_INVOKE_STK1: + opnd = TclGetUInt1AtPtr(pc+1); + TRACE(("%u => ... after \"%.20s\": ", opnd, cmdNameBuf)); + break; + case INST_INVOKE_STK4: + opnd = TclGetUInt4AtPtr(pc+1); + TRACE(("%u => ... after \"%.20s\": ", opnd, cmdNameBuf)); + break; + case INST_EVAL_STK: /* - * Here we do some surgery within the Tcl_Obj internals. We want - * to copy the intrep, but not the string, so we temporarily hide - * the string so we do not copy it. + * Note that the object at stacktop has to be used before doing + * the cleanup. */ - char *savedString = valuePtr->bytes; - - valuePtr->bytes = NULL; - objResultPtr = Tcl_DuplicateObj(valuePtr); - valuePtr->bytes = savedString; - TRACE(("\"%.20s\" => numeric, new Tcl_Obj\n", O2S(valuePtr))); - NEXT_INST_F(1, 1, 1); + TRACE(("\"%.30s\" => ", O2S(OBJ_AT_TOS))); + break; + default: + TRACE(("=> ")); } - TclInvalidateStringRep(valuePtr); - TRACE(("\"%.20s\" => numeric, same Tcl_Obj\n", O2S(valuePtr))); - NEXT_INST_F(1, 0, 0); - } - - /* - * End of numeric operator instructions. - * ----------------------------------------------------------------- - */ +#endif + if ((TRESULT == TCL_CONTINUE) || (TRESULT == TCL_BREAK)) { + rangePtr = GetExceptRangeForPc(pc, /*catchOnly*/ 0, codePtr); + if (rangePtr == NULL) { + TRACE_APPEND(("no encl. loop or catch, returning %s\n", + StringForResultCode(TRESULT))); + goto abnormalReturn; + } + if (rangePtr->type == CATCH_EXCEPTION_RANGE) { + TRACE_APPEND(("%s ...\n", StringForResultCode(TRESULT))); + goto processCatch; + } + while (cleanup--) { + valuePtr = POP_OBJECT(); + TclDecrRefCount(valuePtr); + } + if (TRESULT == TCL_BREAK) { + TRESULT = TCL_OK; + pc = (codePtr->codeStart + rangePtr->breakOffset); + TRACE_APPEND(("%s, range at %d, new pc %d\n", + StringForResultCode(TRESULT), + rangePtr->codeOffset, rangePtr->breakOffset)); + NEXT_INST_F(0, 0, 0); + } + if (rangePtr->continueOffset == -1) { + TRACE_APPEND(("%s, loop w/o continue, checking for catch\n", + StringForResultCode(TRESULT))); + goto checkForCatch; + } + TRESULT = TCL_OK; + pc = (codePtr->codeStart + rangePtr->continueOffset); + TRACE_APPEND(("%s, range at %d, new pc %d\n", + StringForResultCode(TRESULT), + rangePtr->codeOffset, rangePtr->continueOffset)); + NEXT_INST_F(0, 0, 0); + } +#if TCL_COMPILE_DEBUG + if (traceInstructions) { + objPtr = Tcl_GetObjResult(interp); + if ((TRESULT != TCL_ERROR) && (TRESULT != TCL_RETURN)) { + TRACE_APPEND(("OTHER RETURN CODE %d, result= \"%s\"\n ", + TRESULT, O2S(objPtr))); + } else { + TRACE_APPEND(("%s, result= \"%s\"\n", + StringForResultCode(TRESULT), O2S(objPtr))); + } + } +#endif + goto checkForCatch; - case INST_BREAK: /* - DECACHE_STACK_INFO(); - Tcl_ResetResult(interp); - CACHE_STACK_INFO(); - */ - TRESULT = TCL_BREAK; - cleanup = 0; - goto processExceptionReturn; + * Division by zero in an expression. Control only reaches this point + * by "goto divideByZero". + */ - case INST_CONTINUE: - /* - DECACHE_STACK_INFO(); - Tcl_ResetResult(interp); - CACHE_STACK_INFO(); - */ - TRESULT = TCL_CONTINUE; - cleanup = 0; - goto processExceptionReturn; + divideByZero: + Tcl_SetResult(interp, "divide by zero", TCL_STATIC); + Tcl_SetErrorCode(interp, "ARITH", "DIVZERO", "divide by zero", NULL); + goto gotError; - case INST_FOREACH_START4: { /* - * Initialize the temporary local var that holds the count of the - * number of iterations of the loop body to -1. + * Exponentiation of zero by negative number in an expression. Control + * only reaches this point by "goto exponOfZero". */ - int iterTmpIndex; - ForeachInfo *infoPtr; - Var *iterVarPtr; - Tcl_Obj *oldValuePtr; + exponOfZero: + Tcl_SetResult(interp, "exponentiation of zero by negative power", + TCL_STATIC); + Tcl_SetErrorCode(interp, "ARITH", "DOMAIN", + "exponentiation of zero by negative power", NULL); - opnd = TclGetUInt4AtPtr(pc+1); - infoPtr = codePtr->auxDataArrayPtr[opnd].clientData; - iterTmpIndex = infoPtr->loopCtTemp; - iterVarPtr = LOCAL(iterTmpIndex); - oldValuePtr = iterVarPtr->value.objPtr; + /* + * Almost all error paths feed through here rather than assigning to + * TRESULT themselves (for a small but consistent saving). + */ - if (oldValuePtr == NULL) { - TclNewLongObj(iterVarPtr->value.objPtr, -1); - Tcl_IncrRefCount(iterVarPtr->value.objPtr); - } else { - TclSetLongObj(oldValuePtr, -1); - } - TRACE(("%u => loop iter count temp %d\n", opnd, iterTmpIndex)); + gotError: + TRESULT = TCL_ERROR; -#ifndef TCL_COMPILE_DEBUG /* - * Remark that the compiler ALWAYS sets INST_FOREACH_STEP4 immediately - * after INST_FOREACH_START4 - let us just fall through instead of - * jumping back to the top. + * Execution has generated an "exception" such as TCL_ERROR. If the + * exception is an error, record information about what was being + * executed when the error occurred. Find the closest enclosing catch + * range, if any. If no enclosing catch range is found, stop execution + * and return the "exception" code. */ - pc += 5; - TCL_DTRACE_INST_NEXT(); -#else - NEXT_INST_F(5, 0, 0); -#endif - } + checkForCatch: + if (iPtr->execEnvPtr->rewind) { + goto abnormalReturn; + } + if ((TRESULT == 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(); + } + } + iPtr->flags &= ~ERR_ALREADY_LOGGED; - 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. + * Clear all expansions that may have started after the last + * INST_BEGIN_CATCH. */ - ForeachInfo *infoPtr; - ForeachVarList *varListPtr; - Tcl_Obj *listPtr, **elements; - Var *iterVarPtr, *listVarPtr; - int numLists, iterNum, listTmpIndex, listLen, numVars; - int varIndex, valIndex, continueLoop, j; - long i; - - opnd = TclGetUInt4AtPtr(pc+1); - infoPtr = codePtr->auxDataArrayPtr[opnd].clientData; - numLists = infoPtr->numLists; + while (auxObjList) { + if ((catchTop != initCatchTop) && (*catchTop > + (ptrdiff_t) auxObjList->internalRep.twoPtrValue.ptr1)) { + break; + } + POP_TAUX_OBJ(); + } /* - * Increment the temp holding the loop iteration number. + * 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. */ - iterVarPtr = LOCAL(infoPtr->loopCtTemp); - valuePtr = iterVarPtr->value.objPtr; - iterNum = (valuePtr->internalRep.longValue + 1); - TclSetLongObj(valuePtr, iterNum); + if (Tcl_Canceled(interp, 0) == TCL_ERROR) { +#ifdef TCL_COMPILE_DEBUG + if (traceInstructions) { + fprintf(stdout, " ... cancel with unwind, returning %s\n", + StringForResultCode(TRESULT)); + } +#endif + goto abnormalReturn; + } /* - * Check whether all value lists are exhausted and we should stop the - * loop. + * We must not catch an exceeded limit. Instead, it blows outwards + * until we either hit another interpreter (presumably where the limit + * is not exceeded) or we get to the top-level. */ - continueLoop = 0; - listTmpIndex = infoPtr->firstValueTemp; - for (i = 0; i < numLists; i++) { - varListPtr = infoPtr->varLists[i]; - numVars = varListPtr->numVars; - - listVarPtr = LOCAL(listTmpIndex); - listPtr = listVarPtr->value.objPtr; - - if (TclListObjLength(interp, listPtr, &listLen) != TCL_OK) { - TRACE_WITH_OBJ(("%u => ERROR converting list %ld, \"%s\": ", - opnd, i, O2S(listPtr)), Tcl_GetObjResult(interp)); - goto gotError; + if (TclLimitExceeded(iPtr->limit)) { +#ifdef TCL_COMPILE_DEBUG + if (traceInstructions) { + fprintf(stdout, " ... limit exceeded, returning %s\n", + StringForResultCode(TRESULT)); } - - if (listLen > iterNum * numVars) { - continueLoop = 1; +#endif + goto abnormalReturn; + } + if (catchTop == initCatchTop) { +#ifdef TCL_COMPILE_DEBUG + if (traceInstructions) { + fprintf(stdout, " ... no enclosing catch, returning %s\n", + StringForResultCode(TRESULT)); } - listTmpIndex++; +#endif + goto abnormalReturn; } + rangePtr = GetExceptRangeForPc(pc, /*catchOnly*/ 1, codePtr); + if (rangePtr == NULL) { + /* + * This is only possible when compiling a [catch] that sends its + * script to INST_EVAL. Cannot correct the compiler without + * breaking compat with previous .tbc compiled scripts. + */ - /* - * If some var in some var list still has a remaining list element - * iterate one more time. Assign to var the next element from its - * value list. We already checked above that each list temp holds a - * valid list object (by calling Tcl_ListObjLength), but cannot rely - * on that check remaining valid: one list could have been shimmered - * as a side effect of setting a traced variable. - */ - - if (continueLoop) { - listTmpIndex = infoPtr->firstValueTemp; - for (i = 0; i < numLists; i++) { - varListPtr = infoPtr->varLists[i]; - numVars = varListPtr->numVars; - - listVarPtr = LOCAL(listTmpIndex); - listPtr = TclListObjCopy(NULL, listVarPtr->value.objPtr); - TclListObjGetElements(interp, listPtr, &listLen, &elements); - - valIndex = (iterNum * numVars); - for (j = 0; j < numVars; j++) { - if (valIndex >= listLen) { - TclNewObj(valuePtr); - } else { - valuePtr = elements[valIndex]; - } - - varIndex = varListPtr->varIndexes[j]; - varPtr = LOCAL(varIndex); - while (TclIsVarLink(varPtr)) { - varPtr = varPtr->value.linkPtr; - } - if (TclIsVarDirectWritable(varPtr)) { - value2Ptr = varPtr->value.objPtr; - if (valuePtr != value2Ptr) { - if (value2Ptr != NULL) { - TclDecrRefCount(value2Ptr); - } - varPtr->value.objPtr = valuePtr; - Tcl_IncrRefCount(valuePtr); - } - } else { - DECACHE_STACK_INFO(); - value2Ptr = TclPtrSetVar(interp, varPtr, NULL, NULL, - NULL, valuePtr, TCL_LEAVE_ERR_MSG, varIndex); - CACHE_STACK_INFO(); - if (value2Ptr == NULL) { - TRACE_WITH_OBJ(( - "%u => ERROR init. index temp %d: ", - opnd,varIndex), Tcl_GetObjResult(interp)); - TclDecrRefCount(listPtr); - goto gotError; - } - } - valIndex++; - } - TclDecrRefCount(listPtr); - listTmpIndex++; +#ifdef TCL_COMPILE_DEBUG + if (traceInstructions) { + fprintf(stdout, " ... no enclosing catch, returning %s\n", + StringForResultCode(TRESULT)); } +#endif + goto abnormalReturn; } - TRACE(("%u => %d lists, iter %d, %s loop\n", opnd, numLists, - iterNum, (continueLoop? "continue" : "exit"))); /* - * Run-time peep-hole optimisation: the compiler ALWAYS follows - * INST_FOREACH_STEP4 with an INST_JUMP_FALSE. We just skip that - * instruction and jump direct from here. + * A catch exception range (rangePtr) was found to handle an + * "exception". It was found either by checkForCatch just above or by + * an instruction during break, continue, or error processing. Jump to + * its catchOffset after unwinding the operand stack to the depth it + * had when starting to execute the range's catch command. */ - pc += 5; - if (*pc == INST_JUMP_FALSE1) { - NEXT_INST_F((continueLoop? 2 : TclGetInt1AtPtr(pc+1)), 0, 0); - } else { - NEXT_INST_F((continueLoop? 5 : TclGetInt4AtPtr(pc+1)), 0, 0); + processCatch: + while (CURR_DEPTH > *catchTop) { + valuePtr = POP_OBJECT(); + TclDecrRefCount(valuePtr); } - } +#ifdef TCL_COMPILE_DEBUG + if (traceInstructions) { + fprintf(stdout, " ... found catch at %d, catchTop=%d, " + "unwound to %ld, new pc %u\n", + rangePtr->codeOffset, (int) (catchTop - initCatchTop - 1), + (long) *catchTop, (unsigned) rangePtr->catchOffset); + } +#endif + pc = (codePtr->codeStart + rangePtr->catchOffset); + NEXT_INST_F(0, 0, 0); /* Restart the execution loop at pc. */ - case INST_BEGIN_CATCH4: /* - * Record start of the catch command with exception range index equal - * to the operand. Push the current stack depth onto the special catch - * stack. + * end of infinite loop dispatching on instructions. */ - *(++catchTop) = CURR_DEPTH; - TRACE(("%u => catchTop=%d, stackTop=%d\n", - TclGetUInt4AtPtr(pc+1), (int) (catchTop - initCatchTop - 1), - (int) CURR_DEPTH)); - NEXT_INST_F(5, 0, 0); - - case INST_END_CATCH: - catchTop--; - Tcl_ResetResult(interp); - TRESULT = TCL_OK; - TRACE(("=> catchTop=%d\n", (int) (catchTop - initCatchTop - 1))); - NEXT_INST_F(1, 0, 0); - - case INST_PUSH_RESULT: - objResultPtr = Tcl_GetObjResult(interp); - TRACE_WITH_OBJ(("=> "), objResultPtr); - /* - * See the comments at INST_INVOKE_STK + * Abnormal return code. Restore the stack to state it had when + * starting to execute the ByteCode. Panic if the stack is below the + * initial level. */ - TclNewObj(objPtr); - Tcl_IncrRefCount(objPtr); - iPtr->objResultPtr = objPtr; - NEXT_INST_F(1, 0, -1); + abnormalReturn: + TCL_DTRACE_INST_LAST(); - case INST_PUSH_RETURN_CODE: - TclNewIntObj(objResultPtr, TRESULT); - TRACE(("=> %u\n", TRESULT)); - NEXT_INST_F(1, 0, 1); + /* + * Winding down: insure that all pending cleanups are done before + * dropping out of this bytecode. + */ + if (TOP_CB(interp) != BP->rootPtr) { + TRESULT = TclNRRunCallbacks(interp, TRESULT, BP->rootPtr, 1); - case INST_PUSH_RETURN_OPTIONS: - objResultPtr = Tcl_GetReturnOptions(interp, TRESULT); - TRACE_WITH_OBJ(("=> "), objResultPtr); - NEXT_INST_F(1, 0, 1); + if (TOP_CB(interp) != BP->rootPtr) { + Tcl_Panic("Abnormal return with busy callback stack"); + } + } - case INST_RETURN_CODE_BRANCH: { - int code; + /* + * Clear all expansions and same-level NR calls. + * + * Note that expansion markers have a NULL type; avoid removing other + * markers. + */ - if (TclGetIntFromObj(NULL, OBJ_AT_TOS, &code) != TCL_OK) { - Tcl_Panic("INST_RETURN_CODE_BRANCH: TOS not a return code!"); + while (auxObjList) { + POP_TAUX_OBJ(); } - if (code == TCL_OK) { - Tcl_Panic("INST_RETURN_CODE_BRANCH: TOS is TCL_OK!"); + while (tosPtr > initTosPtr) { + objPtr = POP_OBJECT(); + Tcl_DecrRefCount(objPtr); } - if (code < TCL_ERROR || code > TCL_CONTINUE) { - code = TCL_CONTINUE + 1; + + if (tosPtr < initTosPtr) { + fprintf(stderr, + "\nTclExecuteByteCode: abnormal return at pc %u: " + "stack top %d < entry stack top %d\n", + (unsigned)(pc - codePtr->codeStart), + (unsigned) CURR_DEPTH, (unsigned) 0); + Tcl_Panic("TclExecuteByteCode execution failure: end stack top < start stack top"); } - NEXT_INST_F(2*code -1, 1, 0); + CLANG_ASSERT(bcFramePtr); } /* - * ----------------------------------------------------------------- - * Start of dictionary-related instructions. + * Store the previous bottomPtr for returning to it, then free all + * resources used by this bytecode and process callbacks until you return + * to the previous bytecode (if any). */ - { - int opnd2, allocateDict, done, i, allocdict; - Tcl_Obj *dictPtr, *statePtr, *keyPtr; - Tcl_Obj *emptyPtr, **keyPtrPtr; - Tcl_DictSearch *searchPtr; - DictUpdateInfo *duiPtr; + OBP = BP->prevBottomPtr; + iPtr->cmdFramePtr = bcFramePtr->nextPtr; + TclStackFree(interp, BP); /* free my stack */ - case INST_DICT_GET: - opnd = TclGetUInt4AtPtr(pc+1); - TRACE(("%u => ", opnd)); - dictPtr = OBJ_AT_DEPTH(opnd); - if (opnd > 1) { - dictPtr = TclTraceDictPath(interp, dictPtr, opnd-1, - &OBJ_AT_DEPTH(opnd-1), DICT_PATH_READ); - if (dictPtr == NULL) { - TRACE_WITH_OBJ(( - "%u => ERROR tracing dictionary path into \"%s\": ", - opnd, O2S(OBJ_AT_DEPTH(opnd))), - Tcl_GetObjResult(interp)); - goto gotError; - } - } - TRESULT = Tcl_DictObjGet(interp, dictPtr, OBJ_AT_TOS, &objResultPtr); - if ((TRESULT == TCL_OK) && objResultPtr) { - TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); - NEXT_INST_V(5, opnd+1, 1); - } - if (TRESULT != TCL_OK) { - TRACE_WITH_OBJ(( - "%u => ERROR reading leaf dictionary key \"%s\": ", - opnd, O2S(dictPtr)), Tcl_GetObjResult(interp)); - } else { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "key \"", TclGetString(OBJ_AT_TOS), - "\" not known in dictionary", NULL); - TRACE_WITH_OBJ(("%u => ERROR ", opnd), Tcl_GetObjResult(interp)); - } - goto gotError; + if (--codePtr->refCount <= 0) { + TclCleanupByteCode(codePtr); + } - case INST_DICT_SET: - case INST_DICT_UNSET: - case INST_DICT_INCR_IMM: - opnd = TclGetUInt4AtPtr(pc+1); - opnd2 = TclGetUInt4AtPtr(pc+5); + returnToCaller: + if (OBP) { + BP = OBP; /* back to old bc */ + rerunCallbacks: + TRESULT = TclNRRunCallbacks(interp, TRESULT, BP->rootPtr, 1); - varPtr = LOCAL(opnd2); - while (TclIsVarLink(varPtr)) { - varPtr = varPtr->value.linkPtr; - } - TRACE(("%u %u => ", opnd, opnd2)); - if (TclIsVarDirectReadable(varPtr)) { - dictPtr = varPtr->value.objPtr; - } else { - DECACHE_STACK_INFO(); - dictPtr = TclPtrGetVar(interp, varPtr, NULL,NULL,NULL, 0, opnd2); - CACHE_STACK_INFO(); - } - if (dictPtr == NULL) { - TclNewObj(dictPtr); - allocateDict = 1; + NR_DATA_DIG(); + if (TOP_CB(interp) == BP->rootPtr) { + /* + * The bytecode is returning, all callbacks were run: keep + * processing the caller. + */ + + goto nonRecursiveCallReturn; } else { - allocateDict = Tcl_IsShared(dictPtr); - if (allocateDict) { - dictPtr = Tcl_DuplicateObj(dictPtr); + TEOV_callback *callbackPtr = TOP_CB(iPtr); + int type = PTR2INT(callbackPtr->data[0]); + + NRE_ASSERT(TOP_CB(interp)->procPtr == NRCallTEBC); + NRE_ASSERT(TRESULT == TCL_OK); + + switch (type) { + case TCL_NR_BC_TYPE: + /* + * One of the callbacks requested a new execution: a tailcall! + * Start the new bytecode. + */ + + goto nonRecursiveCallSetup; + case TCL_NR_TAILCALL_TYPE: + TOP_CB(iPtr) = callbackPtr->nextPtr; + TCLNR_FREE(interp, callbackPtr); + + Tcl_SetResult(interp, + "tailcall cannot be invoked recursively", TCL_STATIC); + Tcl_SetErrorCode(interp, "TCL", "TAILCALL", "REENTRY", NULL); + TRESULT = TCL_ERROR; + goto rerunCallbacks; + default: + Tcl_Panic("TEBC: TRCB sent us a callback we cannot handle!"); } } + } - switch (*pc) { - case INST_DICT_SET: - cleanup = opnd + 1; - TRESULT = Tcl_DictObjPutKeyList(interp, dictPtr, opnd, - &OBJ_AT_DEPTH(opnd), OBJ_AT_TOS); - break; - case INST_DICT_INCR_IMM: - cleanup = 1; - opnd = TclGetInt4AtPtr(pc+1); - TRESULT = Tcl_DictObjGet(interp, dictPtr, OBJ_AT_TOS, &valuePtr); - if (TRESULT != TCL_OK) { - break; - } - if (valuePtr == NULL) { - Tcl_DictObjPut(NULL, dictPtr, OBJ_AT_TOS,Tcl_NewIntObj(opnd)); - } else { - value2Ptr = Tcl_NewIntObj(opnd); - Tcl_IncrRefCount(value2Ptr); - if (Tcl_IsShared(valuePtr)) { - valuePtr = Tcl_DuplicateObj(valuePtr); - Tcl_DictObjPut(NULL, dictPtr, OBJ_AT_TOS, valuePtr); - } - TRESULT = TclIncrObj(interp, valuePtr, value2Ptr); - if (TRESULT == TCL_OK) { - Tcl_InvalidateStringRep(dictPtr); - } - TclDecrRefCount(value2Ptr); + iPtr->execEnvPtr->bottomPtr = NULL; + return TRESULT; +} +#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, wQuotient, wRemainder; + 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; } - break; - case INST_DICT_UNSET: - cleanup = opnd; - TRESULT = Tcl_DictObjRemoveKeyList(interp, dictPtr, opnd, - &OBJ_AT_DEPTH(opnd-1)); - break; - default: - cleanup = 0; /* stop compiler warning */ - Tcl_Panic("Should not happen!"); - } + if ((l2 == 1) || (l2 == -1)) { + /* + * Div. by |1| always yields remainder of 0. + */ - if (TRESULT != TCL_OK) { - if (allocateDict) { - TclDecrRefCount(dictPtr); + return constants[0]; } - TRACE_WITH_OBJ(("%u %u => ERROR updating dictionary: ", - opnd, opnd2), Tcl_GetObjResult(interp)); - goto gotError; } +#ifndef NO_WIDE_TYPE + if (type1 == TCL_NUMBER_WIDE) { + w1 = *((const Tcl_WideInt *)ptr1); + if (type2 != TCL_NUMBER_BIG) { + Tcl_GetWideIntFromObj(NULL, value2Ptr, &w2); + wQuotient = w1 / w2; - if (TclIsVarDirectWritable(varPtr)) { - if (allocateDict) { - value2Ptr = varPtr->value.objPtr; - Tcl_IncrRefCount(dictPtr); - if (value2Ptr != NULL) { - TclDecrRefCount(value2Ptr); + /* + * 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; } - varPtr->value.objPtr = dictPtr; - } - objResultPtr = dictPtr; - } else { - Tcl_IncrRefCount(dictPtr); - DECACHE_STACK_INFO(); - objResultPtr = TclPtrSetVar(interp, varPtr, NULL, NULL, NULL, - dictPtr, TCL_LEAVE_ERR_MSG, opnd2); - CACHE_STACK_INFO(); - TclDecrRefCount(dictPtr); - if (objResultPtr == NULL) { - TRACE_APPEND(("ERROR: %.30s\n", - O2S(Tcl_GetObjResult(interp)))); - goto gotError; + wRemainder = w1 - w2*wQuotient; + WIDE_RESULT(wRemainder); } - } -#ifndef TCL_COMPILE_DEBUG - if (*(pc+9) == INST_POP) { - NEXT_INST_V(10, cleanup, 0); - } -#endif - TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); - NEXT_INST_V(9, cleanup, 1); - case INST_DICT_APPEND: - case INST_DICT_LAPPEND: - opnd = TclGetUInt4AtPtr(pc+1); + Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2); - varPtr = LOCAL(opnd); - while (TclIsVarLink(varPtr)) { - varPtr = varPtr->value.linkPtr; - } - TRACE(("%u => ", opnd)); - if (TclIsVarDirectReadable(varPtr)) { - dictPtr = varPtr->value.objPtr; - } else { - DECACHE_STACK_INFO(); - dictPtr = TclPtrGetVar(interp, varPtr, NULL, NULL, NULL, 0, opnd); - CACHE_STACK_INFO(); - } - if (dictPtr == NULL) { - TclNewObj(dictPtr); - allocateDict = 1; - } else { - allocateDict = Tcl_IsShared(dictPtr); - if (allocateDict) { - dictPtr = Tcl_DuplicateObj(dictPtr); + /* 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. + */ - if (Tcl_DictObjGet(interp, dictPtr, OBJ_UNDER_TOS, - &valuePtr) != TCL_OK) { - if (allocateDict) { - TclDecrRefCount(dictPtr); - } - goto gotError; + 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: { /* - * 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. + * Reject negative shift argument. */ - switch (*pc) { - case INST_DICT_APPEND: - if (valuePtr == NULL) { - Tcl_DictObjPut(NULL, dictPtr, OBJ_UNDER_TOS, OBJ_AT_TOS); - } else { - if (Tcl_IsShared(valuePtr)) { - valuePtr = Tcl_DuplicateObj(valuePtr); - } - Tcl_AppendObjToObj(valuePtr, OBJ_AT_TOS); - Tcl_DictObjPut(NULL, dictPtr, OBJ_UNDER_TOS, valuePtr); - } + switch (type2) { + case TCL_NUMBER_LONG: + invalid = (*((const long *)ptr2) < 0L); break; - case INST_DICT_LAPPEND: - /* - * More complex because list-append can fail. - */ - - if (valuePtr == NULL) { - valuePtr = Tcl_NewListObj(1, &OBJ_AT_TOS); - Tcl_DictObjPut(NULL, dictPtr, OBJ_UNDER_TOS, valuePtr); - } else if (Tcl_IsShared(valuePtr)) { - valuePtr = Tcl_DuplicateObj(valuePtr); - if (Tcl_ListObjAppendElement(interp, valuePtr, - OBJ_AT_TOS) != TCL_OK) { - TclDecrRefCount(valuePtr); - if (allocateDict) { - TclDecrRefCount(dictPtr); - } - goto gotError; - } - Tcl_DictObjPut(NULL, dictPtr, OBJ_UNDER_TOS, valuePtr); - } else { - if (Tcl_ListObjAppendElement(interp, valuePtr, - OBJ_AT_TOS) != TCL_OK) { - if (allocateDict) { - TclDecrRefCount(dictPtr); - } - goto gotError; - } - } +#ifndef NO_WIDE_TYPE + case TCL_NUMBER_WIDE: + invalid = (*((const Tcl_WideInt *)ptr2) < (Tcl_WideInt)0); + break; +#endif + case TCL_NUMBER_BIG: + Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2); + invalid = (mp_cmp_d(&big2, 0) == MP_LT); + mp_clear(&big2); break; default: - Tcl_Panic("Should not happen!"); + /* Unused, here to silence compiler warning */ + invalid = 0; + } + if (invalid) { + Tcl_SetResult(interp, "negative shift argument", TCL_STATIC); + return GENERAL_ARITHMETIC_ERROR; } - if (TclIsVarDirectWritable(varPtr)) { - if (allocateDict) { - value2Ptr = varPtr->value.objPtr; - Tcl_IncrRefCount(dictPtr); - if (value2Ptr != NULL) { - TclDecrRefCount(value2Ptr); + /* + * Zero shifted any number of bits is still zero. + */ + + if ((type1==TCL_NUMBER_LONG) && (*((const long *)ptr1) == (long)0)) { + return constants[0]; + } + + if (opcode == INST_LSHIFT) { + /* + * Large left shifts create integer overflow. + * + * BEWARE! Can't use Tcl_GetIntFromObj() here because that + * converts values in the (unsigned) range to their signed int + * counterparts, leading to incorrect results. + */ + + if ((type2 != TCL_NUMBER_LONG) + || (*((const long *)ptr2) > (long) INT_MAX)) { + /* + * Technically, we could hold the value (1 << (INT_MAX+1)) in + * an mp_int, but since we're using mp_mul_2d() to do the + * work, and it takes only an int argument, that's a good + * place to draw the line. + */ + + Tcl_SetResult(interp, "integer value too large to represent", + TCL_STATIC); + return GENERAL_ARITHMETIC_ERROR; + } + shift = (int)(*((const long *)ptr2)); + + /* + * Handle shifts within the native wide range. + */ + + if ((type1 != TCL_NUMBER_BIG) + && ((size_t)shift < CHAR_BIT*sizeof(Tcl_WideInt))) { + TclGetWideIntFromObj(NULL, valuePtr, &w1); + if (!((w1>0 ? w1 : ~w1) + & -(((Tcl_WideInt)1) + << (CHAR_BIT*sizeof(Tcl_WideInt) - 1 - shift)))) { + WIDE_RESULT(w1 << shift); } - varPtr->value.objPtr = dictPtr; } - objResultPtr = dictPtr; } else { - Tcl_IncrRefCount(dictPtr); - DECACHE_STACK_INFO(); - objResultPtr = TclPtrSetVar(interp, varPtr, NULL, NULL, NULL, - dictPtr, TCL_LEAVE_ERR_MSG, opnd); - CACHE_STACK_INFO(); - TclDecrRefCount(dictPtr); - if (objResultPtr == NULL) { - TRACE_APPEND(("ERROR: %.30s\n", - O2S(Tcl_GetObjResult(interp)))); - goto gotError; - } - } -#ifndef TCL_COMPILE_DEBUG - if (*(pc+5) == INST_POP) { - NEXT_INST_F(6, 2, 0); - } + /* + * Quickly force large right shifts to 0 or -1. + */ + + if ((type2 != TCL_NUMBER_LONG) + || (*(const long *)ptr2 > INT_MAX)) { + /* + * Again, technically, the value to be shifted could be an + * mp_int so huge that a right shift by (INT_MAX+1) bits could + * not take us to the result of 0 or -1, but since we're using + * mp_div_2d to do the work, and it takes only an int + * argument, we draw the line there. + */ + + switch (type1) { + case TCL_NUMBER_LONG: + zero = (*(const long *)ptr1 > 0L); + break; +#ifndef NO_WIDE_TYPE + case TCL_NUMBER_WIDE: + zero = (*(const Tcl_WideInt *)ptr1 > (Tcl_WideInt)0); + break; #endif - TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); - NEXT_INST_F(5, 2, 1); + 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); - case INST_DICT_FIRST: - opnd = TclGetUInt4AtPtr(pc+1); - TRACE(("%u => ", opnd)); - dictPtr = POP_OBJECT(); - searchPtr = (Tcl_DictSearch *) ckalloc(sizeof(Tcl_DictSearch)); - if (Tcl_DictObjFirst(interp, dictPtr, searchPtr, &keyPtr, &valuePtr, - &done) != TCL_OK) { - ckfree((char *) searchPtr); - goto gotError; - } - TclNewObj(statePtr); - statePtr->typePtr = &dictIteratorType; - statePtr->internalRep.twoPtrValue.ptr1 = searchPtr; - statePtr->internalRep.twoPtrValue.ptr2 = dictPtr; - varPtr = LOCAL(opnd); - if (varPtr->value.objPtr) { - if (varPtr->value.objPtr->typePtr == &dictIteratorType) { - Tcl_Panic("mis-issued dictFirst!"); +#ifndef NO_WIDE_TYPE + /* + * Handle shifts within the native wide range. + */ + + if (type1 == TCL_NUMBER_WIDE) { + w1 = *(const Tcl_WideInt *)ptr1; + if ((size_t)shift >= CHAR_BIT*sizeof(Tcl_WideInt)) { + if (w1 >= (Tcl_WideInt)0) { + return constants[0]; + } + LONG_RESULT(-1); + } + WIDE_RESULT(w1 >> shift); } - TclDecrRefCount(varPtr->value.objPtr); +#endif } - varPtr->value.objPtr = statePtr; - Tcl_IncrRefCount(statePtr); - goto pushDictIteratorResult; - case INST_DICT_NEXT: - opnd = TclGetUInt4AtPtr(pc+1); - TRACE(("%u => ", opnd)); - statePtr = (*LOCAL(opnd)).value.objPtr; - if (statePtr == NULL || statePtr->typePtr != &dictIteratorType) { - Tcl_Panic("mis-issued dictNext!"); - } - searchPtr = statePtr->internalRep.twoPtrValue.ptr1; - Tcl_DictObjNext(searchPtr, &keyPtr, &valuePtr, &done); - pushDictIteratorResult: - if (done) { - TclNewObj(emptyPtr); - PUSH_OBJECT(emptyPtr); - PUSH_OBJECT(emptyPtr); + Tcl_TakeBignumFromObj(NULL, valuePtr, &big1); + + mp_init(&bigResult); + if (opcode == INST_LSHIFT) { + mp_mul_2d(&big1, shift, &bigResult); } else { - PUSH_OBJECT(valuePtr); - PUSH_OBJECT(keyPtr); - } - TRACE_APPEND(("\"%.30s\" \"%.30s\" %d", - O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS), done)); - objResultPtr = TCONST(done); - /* TODO: consider opt like INST_FOREACH_STEP4 */ - NEXT_INST_F(5, 0, 1); + 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. + */ - case INST_DICT_DONE: - opnd = TclGetUInt4AtPtr(pc+1); - TRACE(("%u => ", opnd)); - statePtr = (*LOCAL(opnd)).value.objPtr; - if (statePtr == NULL) { - Tcl_Panic("mis-issued dictDone!"); + 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); - if (statePtr->typePtr == &dictIteratorType) { /* - * First kill the search, and then release the reference to the - * dictionary that we were holding. + * Count how many positive arguments we have. If only one of the + * arguments is negative, store it in 'Second'. */ - searchPtr = statePtr->internalRep.twoPtrValue.ptr1; - Tcl_DictObjDone(searchPtr); - ckfree((char *) searchPtr); + 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); - dictPtr = statePtr->internalRep.twoPtrValue.ptr2; - TclDecrRefCount(dictPtr); + switch (opcode) { + case INST_BITAND: + switch (numPos) { + case 2: + /* + * Both arguments positive, base case. + */ - /* - * Set the internal variable to an empty object to signify that we - * don't hold an iterator. - */ + mp_and(First, Second, &bigResult); + break; + case 1: + /* + * First is positive; second negative: + * P & N = P & ~~N = P&~(-N-1) = P & (P ^ (-N-1)) + */ - TclDecrRefCount(statePtr); - TclNewObj(emptyPtr); - (*LOCAL(opnd)).value.objPtr = emptyPtr; - Tcl_IncrRefCount(emptyPtr); - } - NEXT_INST_F(5, 0, 0); + 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 + */ - case INST_DICT_UPDATE_START: - opnd = TclGetUInt4AtPtr(pc+1); - opnd2 = TclGetUInt4AtPtr(pc+5); - varPtr = LOCAL(opnd); - duiPtr = codePtr->auxDataArrayPtr[opnd2].clientData; - while (TclIsVarLink(varPtr)) { - varPtr = varPtr->value.linkPtr; - } - TRACE(("%u => ", opnd)); - if (TclIsVarDirectReadable(varPtr)) { - dictPtr = varPtr->value.objPtr; - } else { - DECACHE_STACK_INFO(); - dictPtr = TclPtrGetVar(interp, varPtr, NULL, NULL, NULL, - TCL_LEAVE_ERR_MSG, opnd); - CACHE_STACK_INFO(); - if (dictPtr == NULL) { - goto gotError; + 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); } - if (TclListObjGetElements(interp, OBJ_AT_TOS, &length, - &keyPtrPtr) != TCL_OK) { - goto gotError; - } - if (length != duiPtr->length) { - Tcl_Panic("dictUpdateStart argument length mismatch"); - } - for (i=0 ; ivarIndices[i]); - while (TclIsVarLink(varPtr)) { - varPtr = varPtr->value.linkPtr; - } - DECACHE_STACK_INFO(); - if (valuePtr == NULL) { - TclObjUnsetVar2(interp, - localName(iPtr->varFramePtr, duiPtr->varIndices[i]), - NULL, 0); - } else if (TclPtrSetVar(interp, varPtr, NULL, NULL, NULL, - valuePtr, TCL_LEAVE_ERR_MSG, - duiPtr->varIndices[i]) == NULL) { - CACHE_STACK_INFO(); - goto gotError; + +#ifndef NO_WIDE_TYPE + if ((type1 == TCL_NUMBER_WIDE) || (type2 == TCL_NUMBER_WIDE)) { + TclGetWideIntFromObj(NULL, valuePtr, &w1); + TclGetWideIntFromObj(NULL, value2Ptr, &w2); + + switch (opcode) { + case INST_BITAND: + wResult = w1 & w2; + break; + case INST_BITOR: + wResult = w1 | w2; + break; + case INST_BITXOR: + wResult = w1 ^ w2; + break; + default: + /* Unused, here to silence compiler warning. */ + wResult = 0; } - CACHE_STACK_INFO(); + WIDE_RESULT(wResult); } - NEXT_INST_F(9, 0, 0); +#endif + l1 = *((const long *)ptr1); + l2 = *((const long *)ptr2); - case INST_DICT_UPDATE_END: - opnd = TclGetUInt4AtPtr(pc+1); - opnd2 = TclGetUInt4AtPtr(pc+5); - varPtr = LOCAL(opnd); - duiPtr = codePtr->auxDataArrayPtr[opnd2].clientData; - while (TclIsVarLink(varPtr)) { - varPtr = varPtr->value.linkPtr; - } - TRACE(("%u => ", opnd)); - if (TclIsVarDirectReadable(varPtr)) { - dictPtr = varPtr->value.objPtr; - } else { - DECACHE_STACK_INFO(); - dictPtr = TclPtrGetVar(interp, varPtr, NULL, NULL, NULL, 0, opnd); - CACHE_STACK_INFO(); - } - if (dictPtr == NULL) { - NEXT_INST_F(9, 1, 0); - } - if (Tcl_DictObjSize(interp, dictPtr, &length) != TCL_OK - || TclListObjGetElements(interp, OBJ_AT_TOS, &length, - &keyPtrPtr) != TCL_OK) { - goto gotError; - } - allocdict = Tcl_IsShared(dictPtr); - if (allocdict) { - dictPtr = Tcl_DuplicateObj(dictPtr); + 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; } - for (i=0 ; ivarIndices[i]); + LONG_RESULT(lResult); - while (TclIsVarLink(var2Ptr)) { - var2Ptr = var2Ptr->value.linkPtr; - } - if (TclIsVarDirectReadable(var2Ptr)) { - valuePtr = var2Ptr->value.objPtr; - } else { - DECACHE_STACK_INFO(); - valuePtr = TclPtrGetVar(interp, var2Ptr, NULL, NULL, NULL, 0, - duiPtr->varIndices[i]); - CACHE_STACK_INFO(); - } - if (valuePtr == NULL) { - Tcl_DictObjRemove(interp, dictPtr, keyPtrPtr[i]); - } else if (dictPtr == valuePtr) { - Tcl_DictObjPut(interp, dictPtr, keyPtrPtr[i], - Tcl_DuplicateObj(valuePtr)); - } else { - Tcl_DictObjPut(interp, dictPtr, keyPtrPtr[i], valuePtr); + 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; } - if (TclIsVarDirectWritable(varPtr)) { - Tcl_IncrRefCount(dictPtr); - TclDecrRefCount(varPtr->value.objPtr); - varPtr->value.objPtr = dictPtr; - } else { - DECACHE_STACK_INFO(); - objResultPtr = TclPtrSetVar(interp, varPtr, NULL, NULL, NULL, - dictPtr, TCL_LEAVE_ERR_MSG, opnd); - CACHE_STACK_INFO(); - if (objResultPtr == NULL) { - if (allocdict) { - TclDecrRefCount(dictPtr); - } - goto gotError; + 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; } } - NEXT_INST_F(9, 1, 0); - } - /* - * End of dictionary-related instructions. - * ----------------------------------------------------------------- - */ + switch (type2) { + case TCL_NUMBER_LONG: + negativeExponent = (l2 < 0); + oddExponent = (int) (l2 & 1); + break; +#ifndef NO_WIDE_TYPE + case TCL_NUMBER_WIDE: + w2 = *((const Tcl_WideInt *)ptr2); + negativeExponent = (w2 < 0); + oddExponent = (int) (w2 & (Tcl_WideInt)1); + break; +#endif + case TCL_NUMBER_BIG: + Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2); + negativeExponent = (mp_cmp_d(&big2, 0) == MP_LT); + mp_mod_2d(&big2, 1, &big2); + oddExponent = !mp_iszero(&big2); + mp_clear(&big2); + break; + } - default: - Tcl_Panic("TclExecuteByteCode: unrecognized opCode %u", *pc); - } /* end of switch on opCode */ + 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. + */ - /* - * Division by zero in an expression. Control only reaches this point by - * "goto divideByZero". - */ + return EXPONENT_OF_ZERO; + case -1: + if (oddExponent) { + LONG_RESULT(-1); + } + /* fallthrough */ + case 1: + /* + * 1 to any power is 1. + */ - divideByZero: - Tcl_SetResult(interp, "divide by zero", TCL_STATIC); - Tcl_SetErrorCode(interp, "ARITH", "DIVZERO", "divide by zero", NULL); - goto gotError; + return constants[1]; + } + } - /* - * Exponentiation of zero by negative number in an expression. Control - * only reaches this point by "goto exponOfZero". - */ + /* + * Integers with magnitude greater than 1 raise to a negative + * power yield the answer zero (see TIP 123). + */ - exponOfZero: - Tcl_SetResult(interp, "exponentiation of zero by negative power", - TCL_STATIC); - Tcl_SetErrorCode(interp, "ARITH", "DOMAIN", - "exponentiation of zero by negative power", NULL); - goto gotError; + return constants[0]; + } - /* - * Block for variables needed to process exception returns. - */ + if (type1 == TCL_NUMBER_LONG) { + switch (l1) { + case 0: + /* + * Zero to a positive power is zero. + */ - { - ExceptionRange *rangePtr; - /* Points to closest loop or catch exception - * range enclosing the pc. Used by various - * instructions and processCatch to process - * break, continue, and errors. */ - const char *bytes; + return constants[0]; + case 1: + /* + * 1 to any power is 1. + */ + + return constants[1]; + case -1: + if (!oddExponent) { + return constants[1]; + } + LONG_RESULT(-1); + } + } /* - * An external evaluation (INST_INVOKE or INST_EVAL) returned - * something different from TCL_OK, or else INST_BREAK or - * INST_CONTINUE were called. + * 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. */ - processExceptionReturn: -#if TCL_COMPILE_DEBUG - switch (*pc) { - case INST_INVOKE_STK1: - opnd = TclGetUInt1AtPtr(pc+1); - TRACE(("%u => ... after \"%.20s\": ", opnd, cmdNameBuf)); - break; - case INST_INVOKE_STK4: - opnd = TclGetUInt4AtPtr(pc+1); - TRACE(("%u => ... after \"%.20s\": ", opnd, cmdNameBuf)); - break; - case INST_EVAL_STK: - /* - * Note that the object at stacktop has to be used before doing - * the cleanup. - */ - - TRACE(("\"%.30s\" => ", O2S(OBJ_AT_TOS))); - break; - default: - TRACE(("=> ")); + if (type2 != TCL_NUMBER_LONG) { + Tcl_SetResult(interp, "exponent too large", TCL_STATIC); + return GENERAL_ARITHMETIC_ERROR; } + + if (type1 == TCL_NUMBER_LONG) { + if (l1 == 2) { + /* + * Reduce small powers of 2 to shifts. + */ + + if ((unsigned long) l2 < CHAR_BIT * sizeof(long) - 1) { + LONG_RESULT(1L << l2); + } +#if !defined(TCL_WIDE_INT_IS_LONG) + if ((unsigned long)l2 < CHAR_BIT*sizeof(Tcl_WideInt) - 1) { + WIDE_RESULT(((Tcl_WideInt) 1) << l2); + } #endif - if ((TRESULT == TCL_CONTINUE) || (TRESULT == TCL_BREAK)) { - rangePtr = GetExceptRangeForPc(pc, /*catchOnly*/ 0, codePtr); - if (rangePtr == NULL) { - TRACE_APPEND(("no encl. loop or catch, returning %s\n", - StringForResultCode(TRESULT))); - goto abnormalReturn; + goto overflowExpon; } - if (rangePtr->type == CATCH_EXCEPTION_RANGE) { - TRACE_APPEND(("%s ...\n", StringForResultCode(TRESULT))); - goto processCatch; + 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; } - while (cleanup--) { - valuePtr = POP_OBJECT(); - TclDecrRefCount(valuePtr); +#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 (TRESULT == TCL_BREAK) { - TRESULT = TCL_OK; - pc = (codePtr->codeStart + rangePtr->breakOffset); - TRACE_APPEND(("%s, range at %d, new pc %d\n", - StringForResultCode(TRESULT), - 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(TRESULT))); - goto checkForCatch; + + 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. + */ - TRESULT = TCL_OK; - pc = (codePtr->codeStart + rangePtr->continueOffset); - TRACE_APPEND(("%s, range at %d, new pc %d\n", - StringForResultCode(TRESULT), - rangePtr->codeOffset, rangePtr->continueOffset)); - NEXT_INST_F(0, 0, 0); - } -#if TCL_COMPILE_DEBUG - if (traceInstructions) { - objPtr = Tcl_GetObjResult(interp); - if ((TRESULT != TCL_ERROR) && (TRESULT != TCL_RETURN)) { - TRACE_APPEND(("OTHER RETURN CODE %d, result= \"%s\"\n ", - TRESULT, O2S(objPtr))); - } else { - TRACE_APPEND(("%s, result= \"%s\"\n", - StringForResultCode(TRESULT), O2S(objPtr))); + lResult = (oddExponent) ? + -Exp32Value[base] : Exp32Value[base]; + LONG_RESULT(lResult); + } } +#endif } +#if (LONG_MAX > 0x7fffffff) || !defined(TCL_WIDE_INT_IS_LONG) + if (type1 == TCL_NUMBER_LONG) { + w1 = l1; +#ifndef NO_WIDE_TYPE + } else if (type1 == TCL_NUMBER_WIDE) { + w1 = *((const Tcl_WideInt *) ptr1); #endif - goto checkForCatch; - - /* - * Execution has generated an "exception" such as TCL_ERROR. If the - * exception is an error, record information about what was being - * executed when the error occurred. Find the closest enclosing catch - * range, if any. If no enclosing catch range is found, stop execution - * and return the "exception" code. - */ - - gotError: - TRESULT = TCL_ERROR; - checkForCatch: - if (iPtr->execEnvPtr->rewind) { - goto abnormalReturn; + } else { + goto overflowExpon; } - if ((TRESULT == 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(); + 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); } - iPtr->flags &= ~ERR_ALREADY_LOGGED; /* - * Clear all expansions that may have started after the last - * INST_BEGIN_CATCH. + * Handle cases of powers > 16 that still fit in a 64-bit word by + * doing table lookup. */ - while (auxObjList) { - if ((catchTop != initCatchTop) && (*catchTop > - (ptrdiff_t) auxObjList->internalRep.twoPtrValue.ptr1)) { - break; + 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]); } - POP_TAUX_OBJ(); } - /* - * We must not catch if the script in progress has been canceled with - * the TCL_CANCEL_UNWIND flag. Instead, it blows outwards until we - * either hit another interpreter (presumably where the script in - * progress has not been canceled) or we get to the top-level. We do - * NOT modify the interpreter result here because we know it will - * already be set prior to vectoring down to this point in the code. - */ + if (-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. + */ - if (Tcl_Canceled(interp, 0) == TCL_ERROR) { -#ifdef TCL_COMPILE_DEBUG - if (traceInstructions) { - fprintf(stdout, " ... cancel with unwind, returning %s\n", - StringForResultCode(TRESULT)); + wResult = oddExponent ? -Exp64Value[base] : Exp64Value[base]; + WIDE_RESULT(wResult); } + } #endif - goto abnormalReturn; + + overflowExpon: + Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2); + if (big2.used > 1) { + mp_clear(&big2); + Tcl_SetResult(interp, "exponent too large", TCL_STATIC); + return GENERAL_ARITHMETIC_ERROR; } + Tcl_TakeBignumFromObj(NULL, valuePtr, &big1); + mp_init(&bigResult); + mp_expt_d(&big1, big2.dp[0], &bigResult); + mp_clear(&big1); + mp_clear(&big2); + BIG_RESULT(&bigResult); + } - /* - * We must not catch an exceeded limit. Instead, it blows outwards - * until we either hit another interpreter (presumably where the limit - * is not exceeded) or we get to the top-level. - */ + 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. + */ - if (TclLimitExceeded(iPtr->limit)) { -#ifdef TCL_COMPILE_DEBUG - if (traceInstructions) { - fprintf(stdout, " ... limit exceeded, returning %s\n", - StringForResultCode(TRESULT)); - } + 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 - goto abnormalReturn; - } - if (catchTop == initCatchTop) { -#ifdef TCL_COMPILE_DEBUG - if (traceInstructions) { - fprintf(stdout, " ... no enclosing catch, returning %s\n", - StringForResultCode(TRESULT)); + /* + * 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; } -#endif - goto abnormalReturn; - } - rangePtr = GetExceptRangeForPc(pc, /*catchOnly*/ 1, codePtr); - if (rangePtr == NULL) { + + doubleResult: +#ifndef ACCEPT_NAN /* - * This is only possible when compiling a [catch] that sends its - * script to INST_EVAL. Cannot correct the compiler without - * breaking compat with previous .tbc compiled scripts. + * Check now for IEEE floating-point error. */ -#ifdef TCL_COMPILE_DEBUG - if (traceInstructions) { - fprintf(stdout, " ... no enclosing catch, returning %s\n", - StringForResultCode(TRESULT)); + if (TclIsNaN(dResult)) { + TclExprFloatError(interp, dResult); + return GENERAL_ARITHMETIC_ERROR; } #endif - goto abnormalReturn; + DOUBLE_RESULT(dResult); } + if ((type1 != TCL_NUMBER_BIG) && (type2 != TCL_NUMBER_BIG)) { + TclGetWideIntFromObj(NULL, valuePtr, &w1); + TclGetWideIntFromObj(NULL, value2Ptr, &w2); - /* - * A catch exception range (rangePtr) was found to handle an - * "exception". It was found either by checkForCatch just above or by - * an instruction during break, continue, or error processing. Jump to - * its catchOffset after unwinding the operand stack to the depth it - * had when starting to execute the range's catch command. - */ + switch (opcode) { + case INST_ADD: + wResult = w1 + w2; +#ifndef NO_WIDE_TYPE + if ((type1 == TCL_NUMBER_WIDE) || (type2 == TCL_NUMBER_WIDE)) +#endif + { + /* + * Check for overflow. + */ - processCatch: - while (CURR_DEPTH > *catchTop) { - valuePtr = POP_OBJECT(); - TclDecrRefCount(valuePtr); - } -#ifdef TCL_COMPILE_DEBUG - if (traceInstructions) { - fprintf(stdout, " ... found catch at %d, catchTop=%d, " - "unwound to %ld, new pc %u\n", - rangePtr->codeOffset, (int) (catchTop - initCatchTop - 1), - (long) *catchTop, (unsigned) rangePtr->catchOffset); - } + if (Overflowing(w1, w2, wResult)) { + goto overflowBasic; + } + } + break; + + case INST_SUB: + wResult = w1 - w2; +#ifndef NO_WIDE_TYPE + if ((type1 == TCL_NUMBER_WIDE) || (type2 == TCL_NUMBER_WIDE)) #endif - pc = (codePtr->codeStart + rangePtr->catchOffset); - NEXT_INST_F(0, 0, 0); /* Restart the execution loop at pc. */ + { + /* + * 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; - /* - * end of infinite loop dispatching on instructions. - */ + default: + /* + * Unused, here to silence compiler warning. + */ - /* - * Abnormal return code. Restore the stack to state it had when - * starting to execute the ByteCode. Panic if the stack is below the - * initial level. - */ + wResult = 0; + } - abnormalReturn: - TCL_DTRACE_INST_LAST(); + WIDE_RESULT(wResult); + } - /* - * Winding down: insure that all pending cleanups are done before - * dropping out of this bytecode. - */ - if (TOP_CB(interp) != BP->rootPtr) { - TRESULT = TclNRRunCallbacks(interp, TRESULT, BP->rootPtr, 1); + 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. + */ - if (TOP_CB(interp) != BP->rootPtr) { - Tcl_Panic("Abnormal return with busy callback stack"); + mp_sub_d(&bigResult, 1, &bigResult); + mp_add(&bigRemainder, &big2, &bigRemainder); } + mp_clear(&bigRemainder); + break; } + mp_clear(&big1); + mp_clear(&big2); + BIG_RESULT(&bigResult); + } - /* - * Clear all expansions and same-level NR calls. - * - * Note that expansion markers have a NULL type; avoid removing other - * markers. - */ + Tcl_Panic("unexpected opcode"); + return NULL; +} - while (auxObjList) { - POP_TAUX_OBJ(); - } - while (tosPtr > initTosPtr) { - objPtr = POP_OBJECT(); - Tcl_DecrRefCount(objPtr); - } +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; - if (tosPtr < initTosPtr) { - fprintf(stderr, - "\nTclExecuteByteCode: abnormal return at pc %u: " - "stack top %d < entry stack top %d\n", - (unsigned)(pc - codePtr->codeStart), - (unsigned) CURR_DEPTH, (unsigned) 0); - Tcl_Panic("TclExecuteByteCode execution failure: end stack top < start stack top"); + (void) GetNumberFromObj(NULL, valuePtr, &ptr, &type); + + switch (opcode) { + case INST_BITNOT: +#ifndef NO_WIDE_TYPE + if (type == TCL_NUMBER_WIDE) { + w = *((const Tcl_WideInt *) ptr); + WIDE_RESULT(~w); } - CLANG_ASSERT(bcFramePtr); +#endif + Tcl_TakeBignumFromObj(NULL, valuePtr, &big); + /* ~a = - a - 1 */ + mp_neg(&big, &big); + mp_sub_d(&big, 1, &big); + BIG_RESULT(&big); + case INST_UMINUS: + switch (type) { + case TCL_NUMBER_DOUBLE: + DOUBLE_RESULT(-(*((const double *) ptr))); + case TCL_NUMBER_LONG: + w = (Tcl_WideInt) (*((const long *) ptr)); + if (w != LLONG_MIN) { + WIDE_RESULT(-w); + } + TclBNInitBignumFromLong(&big, *(const long *) ptr); + break; +#ifndef NO_WIDE_TYPE + case TCL_NUMBER_WIDE: + w = *((const Tcl_WideInt *) ptr); + if (w != LLONG_MIN) { + WIDE_RESULT(-w); + } + TclBNInitBignumFromWideInt(&big, w); + break; +#endif + default: + Tcl_TakeBignumFromObj(NULL, valuePtr, &big); + } + mp_neg(&big, &big); + BIG_RESULT(&big); } - /* - * Store the previous bottomPtr for returning to it, then free all - * resources used by this bytecode and process callbacks until you return - * to the previous bytecode (if any). - */ + 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. + * + *---------------------------------------------------------------------- + */ - OBP = BP->prevBottomPtr; - iPtr->cmdFramePtr = bcFramePtr->nextPtr; - TclStackFree(interp, BP); /* free my stack */ +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; + Tcl_WideInt w1, w2; - if (--codePtr->refCount <= 0) { - TclCleanupByteCode(codePtr); - } + (void) GetNumberFromObj(NULL, valuePtr, &ptr1, &type1); + (void) GetNumberFromObj(NULL, value2Ptr, &ptr2, &type2); - returnToCaller: - if (OBP) { - BP = OBP; /* back to old bc */ - rerunCallbacks: - TRESULT = TclNRRunCallbacks(interp, TRESULT, BP->rootPtr, 1); + switch (type1) { + case TCL_NUMBER_LONG: + l1 = *((const long *)ptr1); + switch (type2) { + case TCL_NUMBER_LONG: + l2 = *((const long *)ptr2); + longCompare: + return (l1 < l2) ? MP_LT : ((l1 > l2) ? MP_GT : MP_EQ); +#ifndef NO_WIDE_TYPE + case TCL_NUMBER_WIDE: + w2 = *((const Tcl_WideInt *)ptr2); + w1 = (Tcl_WideInt)l1; + goto wideCompare; +#endif + case TCL_NUMBER_DOUBLE: + d2 = *((const double *)ptr2); + d1 = (double) l1; - NR_DATA_DIG(); - if (TOP_CB(interp) == BP->rootPtr) { /* - * The bytecode is returning, all callbacks were run: keep - * processing the caller. + * If the double has a fractional part, or if the long can be + * converted to double without loss of precision, then compare as + * doubles. */ - goto nonRecursiveCallReturn; - } else { - TEOV_callback *callbackPtr = TOP_CB(iPtr); - int type = PTR2INT(callbackPtr->data[0]); + if (DBL_MANT_DIG > CHAR_BIT*sizeof(long) || l1 == (long) d1 + || modf(d2, &tmp) != 0.0) { + goto doubleCompare; + } - NRE_ASSERT(TOP_CB(interp)->procPtr == NRCallTEBC); - NRE_ASSERT(TRESULT == TCL_OK); + /* + * 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. + */ - switch (type) { - case TCL_NR_BC_TYPE: - /* - * One of the callbacks requested a new execution: a tailcall! - * Start the new bytecode. - */ + 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; + } - goto nonRecursiveCallSetup; - case TCL_NR_TAILCALL_TYPE: - TOP_CB(iPtr) = callbackPtr->nextPtr; - TCLNR_FREE(interp, callbackPtr); +#ifndef NO_WIDE_TYPE + case TCL_NUMBER_WIDE: + w1 = *((const Tcl_WideInt *)ptr1); + switch (type2) { + case TCL_NUMBER_WIDE: + w2 = *((const Tcl_WideInt *)ptr2); + wideCompare: + return (w1 < w2) ? MP_LT : ((w1 > w2) ? MP_GT : MP_EQ); + case TCL_NUMBER_LONG: + l2 = *((const long *)ptr2); + w2 = (Tcl_WideInt)l2; + goto wideCompare; + case TCL_NUMBER_DOUBLE: + d2 = *((const double *)ptr2); + d1 = (double) w1; + if (DBL_MANT_DIG > CHAR_BIT*sizeof(Tcl_WideInt) + || w1 == (Tcl_WideInt) d1 || modf(d2, &tmp) != 0.0) { + goto doubleCompare; + } + if (d2 < (double)LLONG_MIN) { + return MP_GT; + } + if (d2 > (double)LLONG_MAX) { + return MP_LT; + } + w2 = (Tcl_WideInt) d2; + goto wideCompare; + case TCL_NUMBER_BIG: + Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2); + if (mp_cmp_d(&big2, 0) == MP_LT) { + compare = MP_GT; + } else { + compare = MP_LT; + } + mp_clear(&big2); + return compare; + } +#endif - Tcl_SetResult(interp, - "tailcall cannot be invoked recursively", TCL_STATIC); - Tcl_SetErrorCode(interp, "TCL", "TAILCALL", "REENTRY", NULL); - TRESULT = TCL_ERROR; - goto rerunCallbacks; - default: - Tcl_Panic("TEBC: TRCB sent us a callback we cannot handle!"); + case TCL_NUMBER_DOUBLE: + d1 = *((const double *)ptr1); + switch (type2) { + case TCL_NUMBER_DOUBLE: + d2 = *((const double *)ptr2); + doubleCompare: + return (d1 < d2) ? MP_LT : ((d1 > d2) ? MP_GT : MP_EQ); + case TCL_NUMBER_LONG: + l2 = *((const long *)ptr2); + d2 = (double) l2; + if (DBL_MANT_DIG > CHAR_BIT*sizeof(long) || l2 == (long) d2 + || modf(d1, &tmp) != 0.0) { + goto doubleCompare; + } + if (d1 < (double)LONG_MIN) { + return MP_LT; + } + if (d1 > (double)LONG_MAX) { + return MP_GT; + } + l1 = (long) d1; + goto longCompare; +#ifndef NO_WIDE_TYPE + case TCL_NUMBER_WIDE: + w2 = *((const Tcl_WideInt *)ptr2); + d2 = (double) w2; + if (DBL_MANT_DIG > CHAR_BIT*sizeof(Tcl_WideInt) + || w2 == (Tcl_WideInt) d2 || modf(d1, &tmp) != 0.0) { + goto doubleCompare; + } + if (d1 < (double)LLONG_MIN) { + return MP_LT; + } + if (d1 > (double)LLONG_MAX) { + return MP_GT; + } + w1 = (Tcl_WideInt) d1; + goto wideCompare; +#endif + case TCL_NUMBER_BIG: + if (TclIsInfinite(d1)) { + return (d1 > 0.0) ? MP_GT : MP_LT; + } + Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2); + if ((d1 < (double)LONG_MAX) && (d1 > (double)LONG_MIN)) { + if (mp_cmp_d(&big2, 0) == MP_LT) { + compare = MP_GT; + } else { + compare = MP_LT; + } + mp_clear(&big2); + return compare; + } + if (DBL_MANT_DIG > CHAR_BIT*sizeof(long) + && modf(d1, &tmp) != 0.0) { + d2 = TclBignumToDouble(&big2); + mp_clear(&big2); + goto doubleCompare; } + Tcl_InitBignumFromDouble(NULL, d1, &big1); + goto bigCompare; } - } - iPtr->execEnvPtr->bottomPtr = NULL; - return TRESULT; + case TCL_NUMBER_BIG: + Tcl_TakeBignumFromObj(NULL, valuePtr, &big1); + switch (type2) { +#ifndef NO_WIDE_TYPE + case TCL_NUMBER_WIDE: +#endif + case TCL_NUMBER_LONG: + compare = mp_cmp_d(&big1, 0); + mp_clear(&big1); + return compare; + case TCL_NUMBER_DOUBLE: + d2 = *((const double *)ptr2); + if (TclIsInfinite(d2)) { + compare = (d2 > 0.0) ? MP_LT : MP_GT; + mp_clear(&big1); + return compare; + } + if ((d2 < (double)LONG_MAX) && (d2 > (double)LONG_MIN)) { + compare = mp_cmp_d(&big1, 0); + mp_clear(&big1); + return compare; + } + if (DBL_MANT_DIG > CHAR_BIT*sizeof(long) + && modf(d2, &tmp) != 0.0) { + d1 = TclBignumToDouble(&big1); + mp_clear(&big1); + goto doubleCompare; + } + Tcl_InitBignumFromDouble(NULL, d2, &big2); + goto bigCompare; + case TCL_NUMBER_BIG: + Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2); + bigCompare: + compare = mp_cmp(&big1, &big2); + mp_clear(&big1); + mp_clear(&big2); + return compare; + } + default: + Tcl_Panic("unexpected number type"); + return TCL_ERROR; + } } -#undef iPtr -#undef bcFramePtr -#undef initCatchTop -#undef initTosPtr -#undef auxObjList -#undef catchTop #ifdef TCL_COMPILE_DEBUG /* diff --git a/generic/tclInt.h b/generic/tclInt.h index 965f69b..55d6f07 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -15,7 +15,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclInt.h,v 1.471 2010/04/25 13:39:25 msofer Exp $ + * RCS: @(#) $Id: tclInt.h,v 1.472 2010/04/28 10:50:37 dkf Exp $ */ #ifndef _TCLINT @@ -890,7 +890,7 @@ typedef struct VarInHash { !((varPtr)->flags & (VAR_ARRAY|VAR_LINK|VAR_TRACED_WRITE|VAR_DEAD_HASH)) #define TclIsVarDirectUnsettable(varPtr) \ - !((varPtr)->flags & (VAR_ARRAY|VAR_LINK|VAR_TRACED_UNSET|VAR_DEAD_HASH)) + !((varPtr)->flags & (VAR_ARRAY|VAR_LINK|VAR_TRACED_READ|VAR_TRACED_WRITE|VAR_TRACED_UNSET|VAR_DEAD_HASH)) #define TclIsVarDirectModifyable(varPtr) \ ( !((varPtr)->flags & (VAR_ARRAY|VAR_LINK|VAR_TRACED_READ|VAR_TRACED_WRITE)) \ -- cgit v0.12