diff options
Diffstat (limited to 'generic')
| -rw-r--r-- | generic/tclExecute.c | 3837 | ||||
| -rw-r--r-- | generic/tclInt.h | 4 |
2 files changed, 1931 insertions, 1910 deletions
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<b) { - Tcl_Obj *temp = *a; - + tmpPtr = *a; *a = *b; - *b = temp; + *b = tmpPtr; a++; b--; } NEXT_INST_F(5, 0, 0); @@ -2573,8 +2581,7 @@ TclExecuteByteCode( NEXT_INST_F(1, 0, 0); case INST_EXPAND_STKTOP: { - int objc, i; - Tcl_Obj **objv; + int i; ptrdiff_t moved; /* @@ -2584,7 +2591,7 @@ TclExecuteByteCode( */ objPtr = OBJ_AT_TOS; - if (TclListObjGetElements(interp, objPtr, &objc, &objv) != TCL_OK){ + if (TclListObjGetElements(interp, objPtr, &objc, &objv) != TCL_OK) { TRACE_WITH_OBJ(("%.30s => 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<listc && toIdx>=0) { + if (fromIdx<=toIdx && fromIdx<objc && toIdx>=0) { if (fromIdx<0) { fromIdx = 0; } - if (toIdx >= listc) { - toIdx = listc-1; + if (toIdx >= objc) { + toIdx = objc-1; } - 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,222 +4929,12 @@ TclExecuteByteCode( iResult = (*pc == INST_NEQ); goto foundResult; } - switch (type1) { - case TCL_NUMBER_LONG: + if ((type1 == TCL_NUMBER_LONG) && (type2 == TCL_NUMBER_LONG)) { l1 = *((const long *)ptr1); - switch (type2) { - case TCL_NUMBER_LONG: - l2 = *((const long *)ptr2); - longCompare: - compare = (l1 < l2) ? MP_LT : ((l1 > l2) ? MP_GT : MP_EQ); - break; -#ifndef NO_WIDE_TYPE - case TCL_NUMBER_WIDE: - w2 = *((const Tcl_WideInt *)ptr2); - w1 = (Tcl_WideInt)l1; - goto wideCompare; -#endif - case TCL_NUMBER_DOUBLE: - d2 = *((const double *)ptr2); - d1 = (double) l1; - - /* - * If the double has a fractional part, or if the long can be - * converted to double without loss of precision, then compare - * as doubles. - */ - - if (DBL_MANT_DIG > CHAR_BIT*sizeof(long) - || l1 == (long) d1 - || modf(d2, &tmp) != 0.0) { - goto doubleCompare; - } - - /* - * Otherwise, to make comparision based on full precision, - * need to convert the double to a suitably sized integer. - * - * Need this to get comparsions like - * expr 20000000000000003 < 20000000000000004.0 - * right. Converting the first argument to double will yield - * two double values that are equivalent within double - * precision. Converting the double to an integer gets done - * exactly, then integer comparison can tell the difference. - */ - - if (d2 < (double)LONG_MIN) { - compare = MP_GT; - break; - } - if (d2 > (double)LONG_MAX) { - compare = MP_LT; - break; - } - l2 = (long) d2; - goto longCompare; - case TCL_NUMBER_BIG: - Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2); - if (mp_cmp_d(&big2, 0) == MP_LT) { - compare = MP_GT; - } else { - compare = MP_LT; - } - mp_clear(&big2); - } - break; - -#ifndef NO_WIDE_TYPE - case TCL_NUMBER_WIDE: - w1 = *((const Tcl_WideInt *)ptr1); - switch (type2) { - case TCL_NUMBER_WIDE: - w2 = *((const Tcl_WideInt *)ptr2); - wideCompare: - compare = (w1 < w2) ? MP_LT : ((w1 > w2) ? MP_GT : MP_EQ); - break; - case TCL_NUMBER_LONG: - l2 = *((const long *)ptr2); - w2 = (Tcl_WideInt)l2; - goto wideCompare; - case TCL_NUMBER_DOUBLE: - d2 = *((const double *)ptr2); - d1 = (double) w1; - if (DBL_MANT_DIG > CHAR_BIT*sizeof(Tcl_WideInt) - || w1 == (Tcl_WideInt) d1 - || modf(d2, &tmp) != 0.0) { - goto doubleCompare; - } - if (d2 < (double)LLONG_MIN) { - compare = MP_GT; - break; - } - if (d2 > (double)LLONG_MAX) { - compare = MP_LT; - break; - } - w2 = (Tcl_WideInt) d2; - goto wideCompare; - case TCL_NUMBER_BIG: - Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2); - if (mp_cmp_d(&big2, 0) == MP_LT) { - compare = MP_GT; - } else { - compare = MP_LT; - } - mp_clear(&big2); - } - break; -#endif - - case TCL_NUMBER_DOUBLE: - d1 = *((const double *)ptr1); - switch (type2) { - case TCL_NUMBER_DOUBLE: - d2 = *((const double *)ptr2); - doubleCompare: - compare = (d1 < d2) ? MP_LT : ((d1 > d2) ? MP_GT : MP_EQ); - break; - case TCL_NUMBER_LONG: - l2 = *((const long *)ptr2); - d2 = (double) l2; - if (DBL_MANT_DIG > CHAR_BIT*sizeof(long) - || l2 == (long) d2 - || modf(d1, &tmp) != 0.0) { - goto doubleCompare; - } - if (d1 < (double)LONG_MIN) { - compare = MP_LT; - break; - } - if (d1 > (double)LONG_MAX) { - compare = MP_GT; - break; - } - l1 = (long) d1; - goto longCompare; -#ifndef NO_WIDE_TYPE - case TCL_NUMBER_WIDE: - w2 = *((const Tcl_WideInt *)ptr2); - d2 = (double) w2; - if (DBL_MANT_DIG > CHAR_BIT*sizeof(Tcl_WideInt) - || w2 == (Tcl_WideInt) d2 - || modf(d1, &tmp) != 0.0) { - goto doubleCompare; - } - if (d1 < (double)LLONG_MIN) { - compare = MP_LT; - break; - } - if (d1 > (double)LLONG_MAX) { - compare = MP_GT; - break; - } - w1 = (Tcl_WideInt) d1; - goto wideCompare; -#endif - case TCL_NUMBER_BIG: - if (TclIsInfinite(d1)) { - compare = (d1 > 0.0) ? MP_GT : MP_LT; - break; - } - Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2); - if ((d1 < (double)LONG_MAX) && (d1 > (double)LONG_MIN)) { - if (mp_cmp_d(&big2, 0) == MP_LT) { - compare = MP_GT; - } else { - compare = MP_LT; - } - mp_clear(&big2); - break; - } - if (DBL_MANT_DIG > CHAR_BIT*sizeof(long) - && modf(d1, &tmp) != 0.0) { - d2 = TclBignumToDouble(&big2); - mp_clear(&big2); - goto doubleCompare; - } - Tcl_InitBignumFromDouble(NULL, d1, &big1); - goto bigCompare; - } - break; - - case TCL_NUMBER_BIG: - Tcl_TakeBignumFromObj(NULL, valuePtr, &big1); - switch (type2) { -#ifndef NO_WIDE_TYPE - case TCL_NUMBER_WIDE: -#endif - case TCL_NUMBER_LONG: - compare = mp_cmp_d(&big1, 0); - mp_clear(&big1); - break; - case TCL_NUMBER_DOUBLE: - d2 = *((const double *)ptr2); - if (TclIsInfinite(d2)) { - compare = (d2 > 0.0) ? MP_LT : MP_GT; - mp_clear(&big1); - break; - } - if ((d2 < (double)LONG_MAX) && (d2 > (double)LONG_MIN)) { - compare = mp_cmp_d(&big1, 0); - mp_clear(&big1); - break; - } - if (DBL_MANT_DIG > CHAR_BIT*sizeof(long) - && modf(d2, &tmp) != 0.0) { - d1 = TclBignumToDouble(&big1); - mp_clear(&big1); - goto doubleCompare; - } - Tcl_InitBignumFromDouble(NULL, d2, &big2); - goto bigCompare; - case TCL_NUMBER_BIG: - Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2); - bigCompare: - compare = mp_cmp(&big1, &big2); - mp_clear(&big1); - mp_clear(&big2); - } + l2 = *((const long *)ptr2); + compare = (l1 < l2) ? MP_LT : ((l1 > l2) ? MP_GT : MP_EQ); + } else { + compare = TclCompareTwoNumbers(valuePtr, value2Ptr); } /* @@ -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,636 +5012,198 @@ TclExecuteByteCode( goto gotError; } - if (*pc == INST_MOD) { - /* TODO: Attempts to re-use unshared operands on stack */ + /* + * Check for common, simple case. + */ - l2 = 0; /* silence gcc warning */ - if (type2 == TCL_NUMBER_LONG) { - l2 = *((const long *)ptr2); + if ((type1 == TCL_NUMBER_LONG) && (type2 == TCL_NUMBER_LONG)) { + l1 = *((const long *)ptr1); + l2 = *((const long *)ptr2); + + switch (*pc) { + case INST_MOD: if (l2 == 0) { TRACE(("%s %s => DIVIDE BY ZERO\n", O2S(valuePtr), O2S(value2Ptr))); goto divideByZero; - } - 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. - */ - - TRACE(("%s\n", O2S(valuePtr))); - NEXT_INST_F(1, 1, 0); - } -#endif - Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2); - - /* TODO: internals intrusion */ - if ((l1 > 0) ^ (big2.sign == MP_ZPOS)) { - /* - * Arguments are opposite sign; remainder is sum. + * Handle shifts within the native long range. */ - TclBNInitBignumFromLong(&big1, l1); - mp_add(&big2, &big1, &big2); - mp_clear(&big1); - objResultPtr = Tcl_NewBignumObj(&big2); - TRACE(("%s\n", O2S(objResultPtr))); - NEXT_INST_F(1, 2, 1); + lResult = l1 >> ((int) l2); + goto longResultOfArithmetic; } - /* - * 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; - - Tcl_GetWideIntFromObj(NULL, value2Ptr, &w2); - wQuotient = w1 / w2; - - /* - * Force Tcl's integer division rules. - * TODO: examine for logic simplification - */ - - if (((wQuotient < (Tcl_WideInt) 0) - || ((wQuotient == (Tcl_WideInt) 0) - && ((w1 < (Tcl_WideInt)0 && w2 > (Tcl_WideInt)0) - || (w1 > (Tcl_WideInt)0 && w2 < (Tcl_WideInt)0)))) - && (wQuotient * w2 != w1)) { - wQuotient -= (Tcl_WideInt) 1; - } - wRemainder = w1 - w2*wQuotient; - objResultPtr = Tcl_NewWideIntObj(wRemainder); + 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); - } - - Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2); - - /* TODO: internals intrusion */ - if ((w1 > ((Tcl_WideInt) 0)) ^ (big2.sign == MP_ZPOS)) { + } else if (l2 > (long) INT_MAX) { /* - * Arguments are opposite sign; remainder is sum. + * 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. */ - TclBNInitBignumFromWideInt(&big1, w1); - mp_add(&big2, &big1, &big2); - mp_clear(&big1); - objResultPtr = Tcl_NewBignumObj(&big2); - TRACE(("%s\n", O2S(objResultPtr))); - NEXT_INST_F(1, 2, 1); - } - - /* - * Arguments are same sign; remainder is first operand. - */ - - mp_clear(&big2); - 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. - */ - - 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); - goto gotError; - } - - /* - * Zero shifted any number of bits is still zero. - */ - - if ((type1==TCL_NUMBER_LONG) && (*((const long *)ptr1) == (long)0)) { - TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); - objResultPtr = TCONST(0); - TRACE(("%s\n", O2S(objResultPtr))); - NEXT_INST_F(1, 2, 1); - } - - if (*pc == INST_LSHIFT) { - /* - * Large left shifts create integer overflow. - * - * BEWARE! Can't use Tcl_GetIntFromObj() here because that - * converts values in the (unsigned) range to their signed int - * counterparts, leading to incorrect results. - */ - - if ((type2 != TCL_NUMBER_LONG) - || (*((const long *)ptr2) > (long) INT_MAX)) { - /* - * Technically, we could hold the value (1 << (INT_MAX+1)) in - * an mp_int, but since we're using mp_mul_2d() to do the - * work, and it takes only an int argument, that's a good - * place to draw the line. - */ - - Tcl_SetResult(interp, "integer value too large to represent", - TCL_STATIC); - goto gotError; - } - shift = (int)(*((const long *)ptr2)); - - /* - * Handle shifts within the native long range. - */ - - TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); - if ((type1 == TCL_NUMBER_LONG) - && (size_t) shift < CHAR_BIT*sizeof(long) - && ((l1 = *(const long *)ptr1) != 0) - && !((l1>0 ? l1 : ~l1) - & -(1L<<(CHAR_BIT*sizeof(long) - 1 - shift)))) { - TclNewLongObj(objResultPtr, (l1<<shift)); - TRACE(("%s\n", O2S(objResultPtr))); - NEXT_INST_F(1, 2, 1); - } - - /* - * Handle shifts within the native wide range. - */ - - TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); - if ((type1 != TCL_NUMBER_BIG) - && ((size_t)shift < CHAR_BIT*sizeof(Tcl_WideInt))) { - TclGetWideIntFromObj(NULL, valuePtr, &w1); - if (!((w1>0 ? w1 : ~w1) - & -(((Tcl_WideInt)1) - << (CHAR_BIT*sizeof(Tcl_WideInt) - 1 - shift)))) { - objResultPtr = Tcl_NewWideIntObj(w1<<shift); - TRACE(("%s\n", O2S(objResultPtr))); - NEXT_INST_F(1, 2, 1); - } - } - } else { - /* - * Quickly force large right shifts to 0 or -1. - */ - - TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); - if ((type2 != TCL_NUMBER_LONG) - || (*(const long *)ptr2 > INT_MAX)) { - /* - * Again, technically, the value to be shifted could be an - * mp_int so huge that a right shift by (INT_MAX+1) bits could - * not take us to the result of 0 or -1, but since we're using - * mp_div_2d to do the work, and it takes only an int - * argument, we draw the line there. - */ - - int zero; - - switch (type1) { - case TCL_NUMBER_LONG: - zero = (*(const long *)ptr1 > 0L); - break; -#ifndef NO_WIDE_TYPE - case TCL_NUMBER_WIDE: - zero = (*(const Tcl_WideInt *)ptr1 > (Tcl_WideInt)0); - break; + 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 - 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) { - objResultPtr = TCONST(0); - } else { - TclNewIntObj(objResultPtr, -1); - } - TRACE(("%s\n", O2S(objResultPtr))); - NEXT_INST_F(1, 2, 1); - } - shift = (int)(*(const long *)ptr2); - - /* - * Handle shifts within the native long range. - */ - - if (type1 == TCL_NUMBER_LONG) { - l1 = *((const long *)ptr1); - if ((size_t)shift >= CHAR_BIT*sizeof(long)) { - if (l1 >= (long)0) { - objResultPtr = TCONST(0); - } else { - TclNewIntObj(objResultPtr, -1); - } + goto gotError; } else { - TclNewLongObj(objResultPtr, (l1 >> shift)); - } - TRACE(("%s\n", O2S(objResultPtr))); - NEXT_INST_F(1, 2, 1); - } + int shift = (int) l2; -#ifndef NO_WIDE_TYPE - /* - * Handle shifts within the native wide range. - */ + /* + * Handle shifts within the native long 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) { - objResultPtr = TCONST(0); - } else { - TclNewIntObj(objResultPtr, -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; } - } 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); - } 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. + * Too large; need to use the broken-out function. */ - mp_sub_d(&bigResult, 1, &bigResult); - } - mp_clear(&bigRemainder); - } - mp_clear(&big1); - - if (!Tcl_IsShared(valuePtr)) { - Tcl_SetBignumObj(valuePtr, &bigResult); - TRACE(("%s\n", O2S(valuePtr))); - NEXT_INST_F(1, 1, 0); - } - objResultPtr = Tcl_NewBignumObj(&bigResult); - TRACE(("%s\n", O2S(objResultPtr))); - NEXT_INST_F(1, 2, 1); - } - - case INST_BITOR: - case INST_BITXOR: - case INST_BITAND: - value2Ptr = OBJ_AT_TOS; - valuePtr = OBJ_UNDER_TOS; - - 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"))); - 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); - goto gotError; - } - - if ((type1 == TCL_NUMBER_BIG) || (type2 == TCL_NUMBER_BIG)) { - mp_int *First, *Second; - int numPos; - - Tcl_TakeBignumFromObj(NULL, valuePtr, &big1); - Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2); - - /* - * Count how many positive arguments we have. If only one of the - * arguments is negative, store it in 'Second'. - */ - - if (mp_cmp_d(&big1, 0) != MP_LT) { - numPos = 1 + (mp_cmp_d(&big2, 0) != MP_LT); - First = &big1; - Second = &big2; - } else { - First = &big2; - Second = &big1; - numPos = (mp_cmp_d(First, 0) != MP_LT); - } - mp_init(&bigResult); - - switch (*pc) { - case INST_BITAND: - switch (numPos) { - case 2: - /* - * Both arguments positive, base case. - */ - - mp_and(First, Second, &bigResult); - break; - case 1: - /* - * First is positive; second negative: - * P & N = P & ~~N = P&~(-N-1) = P & (P ^ (-N-1)) - */ - - mp_neg(Second, Second); - mp_sub_d(Second, 1, Second); - mp_xor(First, Second, &bigResult); - mp_and(First, &bigResult, &bigResult); - break; - case 0: - /* - * Both arguments negative: - * a & b = ~ (~a | ~b) = -(-a-1|-b-1)-1 - */ - - mp_neg(First, First); - mp_sub_d(First, 1, First); - mp_neg(Second, Second); - mp_sub_d(Second, 1, Second); - mp_or(First, Second, &bigResult); - mp_neg(&bigResult, &bigResult); - mp_sub_d(&bigResult, 1, &bigResult); - break; - } - break; - - case INST_BITOR: - switch (numPos) { - case 2: - /* - * Both arguments positive, base case. - */ - - mp_or(First, Second, &bigResult); - break; - case 1: - /* - * First is positive; second negative: - * N|P = ~(~N&~P) = ~((-N-1)&~P) = -((-N-1)&((-N-1)^P))-1 - */ - - mp_neg(Second, Second); - mp_sub_d(Second, 1, Second); - mp_xor(First, Second, &bigResult); - mp_and(Second, &bigResult, &bigResult); - mp_neg(&bigResult, &bigResult); - mp_sub_d(&bigResult, 1, &bigResult); - break; - case 0: - /* - * Both arguments negative: - * a | b = ~ (~a & ~b) = -(-a-1&-b-1)-1 - */ - - mp_neg(First, First); - mp_sub_d(First, 1, First); - mp_neg(Second, Second); - mp_sub_d(Second, 1, Second); - mp_and(First, Second, &bigResult); - mp_neg(&bigResult, &bigResult); - mp_sub_d(&bigResult, 1, &bigResult); - break; - } - break; - - case INST_BITXOR: - switch (numPos) { - case 2: - /* - * Both arguments positive, base case. - */ - - mp_xor(First, Second, &bigResult); - break; - case 1: - /* - * First is positive; second negative: - * P^N = ~(P^~N) = -(P^(-N-1))-1 - */ - - mp_neg(Second, Second); - mp_sub_d(Second, 1, Second); - mp_xor(First, Second, &bigResult); - mp_neg(&bigResult, &bigResult); - mp_sub_d(&bigResult, 1, &bigResult); - break; - case 0: - /* - * Both arguments negative: - * a ^ b = (~a ^ ~b) = (-a-1^-b-1) - */ - - mp_neg(First, First); - mp_sub_d(First, 1, First); - mp_neg(Second, Second); - mp_sub_d(Second, 1, Second); - mp_xor(First, Second, &bigResult); - break; - } + TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); break; - } - - mp_clear(&big1); - mp_clear(&big2); - TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); - if (Tcl_IsShared(valuePtr)) { - objResultPtr = Tcl_NewBignumObj(&bigResult); - TRACE(("%s\n", O2S(objResultPtr))); - NEXT_INST_F(1, 2, 1); - } - Tcl_SetBignumObj(valuePtr, &bigResult); - TRACE(("%s\n", O2S(valuePtr))); - NEXT_INST_F(1, 1, 0); - } - -#ifndef NO_WIDE_TYPE - if ((type1 == TCL_NUMBER_WIDE) || (type2 == TCL_NUMBER_WIDE)) { - TclGetWideIntFromObj(NULL, valuePtr, &w1); - TclGetWideIntFromObj(NULL, value2Ptr, &w2); - switch (*pc) { case INST_BITAND: - wResult = w1 & w2; - break; + lResult = l1 & l2; + goto longResultOfArithmetic; case INST_BITOR: - wResult = w1 | w2; - break; + lResult = l1 | l2; + goto longResultOfArithmetic; case INST_BITXOR: - wResult = w1 ^ w2; - break; - default: - /* Unused, here to silence compiler warning. */ - wResult = 0; - } - - TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); - if (Tcl_IsShared(valuePtr)) { - objResultPtr = Tcl_NewWideIntObj(wResult); - TRACE(("%s\n", O2S(objResultPtr))); - NEXT_INST_F(1, 2, 1); + lResult = l1 ^ l2; + longResultOfArithmetic: + TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); + if (Tcl_IsShared(valuePtr)) { + TclNewLongObj(objResultPtr, lResult); + TRACE(("%s\n", O2S(objResultPtr))); + NEXT_INST_F(1, 2, 1); + } + TclSetLongObj(valuePtr, lResult); + TRACE(("%s\n", O2S(valuePtr))); + NEXT_INST_F(1, 1, 0); } - Tcl_SetWideIntObj(valuePtr, wResult); - TRACE(("%s\n", O2S(valuePtr))); - NEXT_INST_F(1, 1, 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; - } + /* + * DO NOT MERGE THIS WITH THE EQUIVALENT SECTION LATER! That would + * encourage the compiler to inline ExecuteExtendedBinaryMathOp, which + * is highly undesirable due to the overall impact on size. + */ TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); - if (Tcl_IsShared(valuePtr)) { - TclNewLongObj(objResultPtr, lResult); - TRACE(("%s\n", O2S(objResultPtr))); + 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); } - TclSetLongObj(valuePtr, lResult); - TRACE(("%s\n", O2S(valuePtr))); - NEXT_INST_F(1, 1, 0); case INST_EXPON: case INST_ADD: @@ -5936,8 +5213,8 @@ TclExecuteByteCode( value2Ptr = OBJ_AT_TOS; valuePtr = OBJ_UNDER_TOS; - TRESULT = GetNumberFromObj(NULL, valuePtr, &ptr1, &type1); - if ((TRESULT != TCL_OK) || IsErroringNaNType(type1)) { + 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"))); @@ -5955,8 +5232,8 @@ TclExecuteByteCode( } #endif - TRESULT = GetNumberFromObj(NULL, value2Ptr, &ptr2, &type2); - if ((TRESULT != TCL_OK) || IsErroringNaNType(type2)) { + if ((GetNumberFromObj(NULL, value2Ptr, &ptr2, &type2) != TCL_OK) + || IsErroringNaNType(type2)) { TRACE(("%.20s %.20s => ILLEGAL 2nd TYPE %s\n", O2S(value2Ptr), O2S(valuePtr), (value2Ptr->typePtr? value2Ptr->typePtr->name: "null"))); @@ -5975,679 +5252,127 @@ TclExecuteByteCode( } #endif - if ((type1 == TCL_NUMBER_DOUBLE) || (type2 == TCL_NUMBER_DOUBLE)) { - /* - * At least one of the values is floating-point, so perform - * floating point calculations. - */ - - Tcl_GetDoubleFromObj(NULL, valuePtr, &d1); - Tcl_GetDoubleFromObj(NULL, value2Ptr, &d2); - - 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. - */ - - dResult = d1 / d2; - break; - case INST_EXPON: - if (d1==0.0 && d2<0.0) { - TRACE(("%.6g %.6g => EXPONENT OF ZERO\n", d1, d2)); - goto exponOfZero; - } - dResult = pow(d1, d2); - break; - default: - /* Unused, here to silence compiler warning. */ - dResult = 0; - } - -#ifndef ACCEPT_NAN - /* - * Check now for IEEE floating-point error. - */ + /* + * Handle (long,long) arithmetic as best we can without going out to + * an external function. + */ - 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); - } - TclSetDoubleObj(valuePtr, dResult); - TRACE(("%s\n", O2S(valuePtr))); - NEXT_INST_F(1, 1, 0); - } + if ((type1 == TCL_NUMBER_LONG) && (type2 == TCL_NUMBER_LONG)) { + Tcl_WideInt w1, w2, wResult; - 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); - 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); - } - } - - 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); - - wResult = w1 * w2; - - TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); - if (Tcl_IsShared(valuePtr)) { - objResultPtr = Tcl_NewWideIntObj(wResult); - TRACE(("%s\n", O2S(objResultPtr))); - NEXT_INST_F(1, 2, 1); - } - Tcl_SetWideIntObj(valuePtr, wResult); - TRACE(("%s\n", O2S(valuePtr))); - NEXT_INST_F(1, 1, 0); - } - - /* TODO: Attempts to re-use unshared operands on stack. */ - if (*pc == INST_EXPON) { - int oddExponent = 0, negativeExponent = 0; - unsigned short base; - - l1 = l2 = 0; - if (type2 == TCL_NUMBER_LONG) { - l2 = *((const long *) ptr2); - if (l2 == 0) { - /* - * Anything to the zero power is 1. - */ - - 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); - } - } - - switch (type2) { - case TCL_NUMBER_LONG: { - negativeExponent = (l2 < 0); - oddExponent = (int) (l2 & 1); - break; - } -#ifndef NO_WIDE_TYPE - case TCL_NUMBER_WIDE: - w2 = *((const Tcl_WideInt *)ptr2); - negativeExponent = (w2 < 0); - oddExponent = (int) (w2 & (Tcl_WideInt)1); - break; -#endif - case TCL_NUMBER_BIG: - Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2); - negativeExponent = (mp_cmp_d(&big2, 0) == MP_LT); - mp_mod_2d(&big2, 1, &big2); - oddExponent = !mp_iszero(&big2); - mp_clear(&big2); - break; - } - - if (type1 == TCL_NUMBER_LONG) { - l1 = *((const long *)ptr1); - } - if (negativeExponent) { - if (type1 == TCL_NUMBER_LONG) { - switch (l1) { - case 0: - /* - * Zero to a negative power is div by zero error. - */ - - 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. - */ - - objResultPtr = TCONST(1); - NEXT_INST_F(1, 2, 1); - } - } - + switch (*pc) { + case INST_ADD: + w1 = (Tcl_WideInt) l1; + w2 = (Tcl_WideInt) l2; + wResult = w1 + w2; +#ifdef NO_WIDE_TYPE /* - * Integers with magnitude greater than 1 raise to a negative - * power yield the answer zero (see TIP 123). + * Check for overflow. */ - 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. - */ - - 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); - } - } - - /* - * We refuse to accept exponent arguments that exceed one mp_digit - * which means the max exponent value is 2**28-1 = 0x0fffffff = - * 268435455, which fits into a signed 32 bit int which is within - * the range of the long int type. This means any numeric Tcl_Obj - * value not using TCL_NUMBER_LONG type must hold a value larger - * than we accept. - */ - - if (type2 != TCL_NUMBER_LONG) { - Tcl_SetResult(interp, "exponent too large", TCL_STATIC); - 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 + if (Overflowing(w1, w2, wResult)) { goto overflow; } - if (l1 == -2) { - int signum = oddExponent ? -1 : 1; - - /* - * Reduce small powers of 2 to shifts. - */ - - if ((unsigned long) l2 < CHAR_BIT * sizeof(long) - 1) { - TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); - TclNewLongObj(objResultPtr, signum * (1L << l2)); - TRACE(("%s\n", O2S(objResultPtr))); - NEXT_INST_F(1, 2, 1); - } -#if !defined(TCL_WIDE_INT_IS_LONG) - if ((unsigned long)l2 < CHAR_BIT*sizeof(Tcl_WideInt) - 1){ - TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); - objResultPtr = Tcl_NewWideIntObj( - signum * (((Tcl_WideInt) 1) << l2)); - TRACE(("%s\n", O2S(objResultPtr))); - NEXT_INST_F(1, 2, 1); - } #endif - goto overflow; - } -#if (LONG_MAX == 0x7fffffff) - if (l2 - 2 < (long)MaxBase32Size - && l1 <= MaxBase32[l2 - 2] - && l1 >= -MaxBase32[l2 - 2]) { - /* - * Small powers of 32-bit integers. - */ - - 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. - */ + goto wideResultOfArithmetic; - 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. - */ - - 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 - } -#if (LONG_MAX > 0x7fffffff) || !defined(TCL_WIDE_INT_IS_LONG) - if (type1 == TCL_NUMBER_LONG) { - w1 = l1; -#ifndef NO_WIDE_TYPE - } else if (type1 == TCL_NUMBER_WIDE) { - w1 = *((const Tcl_WideInt *) ptr1); -#endif - } else { - goto overflow; - } - if (l2 - 2 < (long)MaxBase64Size - && w1 <= MaxBase64[l2 - 2] - && w1 >= -MaxBase64[l2 - 2]) { + case INST_SUB: + w1 = (Tcl_WideInt) l1; + w2 = (Tcl_WideInt) l2; + wResult = w1 - w2; +#ifdef NO_WIDE_TYPE /* - * Small powers of integers whose result is wide. + * 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. */ - wResult = w1 * w1; /* b**2 */ - switch (l2) { - case 2: - break; - case 3: - wResult *= l1; /* b**3 */ - break; - case 4: - wResult *= wResult; /* b**4 */ - break; - case 5: - wResult *= wResult; /* b**4 */ - wResult *= w1; /* b**5 */ - break; - case 6: - wResult *= w1; /* b**3 */ - wResult *= wResult; /* b**6 */ - break; - case 7: - wResult *= w1; /* b**3 */ - wResult *= wResult; /* b**6 */ - wResult *= w1; /* b**7 */ - break; - case 8: - wResult *= wResult; /* b**4 */ - wResult *= wResult; /* b**8 */ - break; - case 9: - wResult *= wResult; /* b**4 */ - wResult *= wResult; /* b**8 */ - wResult *= w1; /* b**9 */ - break; - case 10: - wResult *= wResult; /* b**4 */ - wResult *= w1; /* b**5 */ - wResult *= wResult; /* b**10 */ - break; - case 11: - wResult *= wResult; /* b**4 */ - wResult *= w1; /* b**5 */ - wResult *= wResult; /* b**10 */ - wResult *= w1; /* b**11 */ - break; - case 12: - wResult *= w1; /* b**3 */ - wResult *= wResult; /* b**6 */ - wResult *= wResult; /* b**12 */ - break; - case 13: - wResult *= w1; /* b**3 */ - wResult *= wResult; /* b**6 */ - wResult *= wResult; /* b**12 */ - wResult *= w1; /* b**13 */ - break; - case 14: - wResult *= w1; /* b**3 */ - wResult *= wResult; /* b**6 */ - wResult *= w1; /* b**7 */ - wResult *= wResult; /* b**14 */ - break; - case 15: - wResult *= w1; /* b**3 */ - wResult *= wResult; /* b**6 */ - wResult *= w1; /* b**7 */ - wResult *= wResult; /* b**14 */ - wResult *= w1; /* b**15 */ - break; - case 16: - wResult *= wResult; /* b**4 */ - wResult *= wResult; /* b**8 */ - wResult *= wResult; /* b**16 */ - break; - } - TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); - objResultPtr = Tcl_NewWideIntObj(wResult); - TRACE(("%s\n", O2S(objResultPtr))); - NEXT_INST_F(1, 2, 1); - } - - /* - * Handle cases of powers > 16 that still fit in a 64-bit word by - * doing table lookup. - */ - - if (w1 - 3 >= 0 && w1 - 2 < (long)Exp64IndexSize - && l2 - 2 < (long)(Exp64ValueSize + MaxBase64Size)) { - base = Exp64Index[w1 - 3] - + (unsigned short) (l2 - 2 - MaxBase64Size); - if (base < Exp64Index[w1 - 2]) { - /* - * 64-bit number raised to intermediate power, done by - * table lookup. - */ - - TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); - if (Tcl_IsShared(valuePtr)) { - objResultPtr = Tcl_NewWideIntObj(Exp64Value[base]); - TRACE(("%s\n", O2S(objResultPtr))); - NEXT_INST_F(1, 2, 1); - } - Tcl_SetWideIntObj(valuePtr, Exp64Value[base]); - TRACE(("%s\n", O2S(valuePtr))); - NEXT_INST_F(1, 1, 0); - } - } - - if (-w1 - 3 >= 0 && -w1 - 2 < (long)Exp64IndexSize - && l2 - 2 < (long)(Exp64ValueSize + MaxBase64Size)) { - 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); - } - } -#endif - - goto overflow; - } - - 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 (Overflowing(w1, ~w2, wResult)) { + goto overflow; } - break; - - case INST_SUB: - wResult = w1 - w2; -#ifndef NO_WIDE_TYPE - if ((type1 == TCL_NUMBER_WIDE) || (type2 == TCL_NUMBER_WIDE)) #endif - { - /* - * Must check for overflow. The macro tests for overflows - * in sums by looking at the sign bits. As we have a - * subtraction here, we are adding -w2. As -w2 could in - * turn overflow, we test with ~w2 instead: it has the - * opposite sign bit to w2 so it does the job. Note that - * the only "bad" case (w2==0) is irrelevant for this - * macro, as in that case w1 and wResult have the same - * sign and there is no overflow anyway. - */ - - if (Overflowing(w1, ~w2, wResult)) { - goto overflow; - } + 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); } - break; + Tcl_SetWideIntObj(valuePtr, wResult); + TRACE(("%s\n", O2S(valuePtr))); + NEXT_INST_F(1, 1, 0); case INST_DIV: - if (w2 == 0) { + if (l2 == 0) { TRACE(("%s %s => DIVIDE BY ZERO\n", O2S(valuePtr), O2S(value2Ptr))); goto divideByZero; - } - - /* - * Need a bignum to represent (LLONG_MIN / -1) - */ + } else if ((l1 == LONG_MIN) && (l2 == -1)) { + /* + * Can't represent (-LONG_MIN) as a long. + */ - if ((w1 == LLONG_MIN) && (w2 == -1)) { goto overflow; } - wResult = w1 / w2; + lResult = l1 / l2; /* * Force Tcl's integer division rules. * TODO: examine for logic simplification */ - if (((wResult < 0) || ((wResult == 0) && - ((w1 < 0 && w2 > 0) || (w1 > 0 && w2 < 0)))) && - ((wResult * w2) != w1)) { - wResult -= 1; + if (((lResult < 0) || ((lResult == 0) && + ((l1 < 0 && l2 > 0) || (l1 > 0 && l2 < 0)))) && + ((lResult * l2) != l1)) { + lResult -= 1; } - break; - default: - /* - * Unused, here to silence compiler warning. - */ + goto longResultOfArithmetic; - wResult = 0; + case INST_MULT: + if (((sizeof(long) >= 2*sizeof(int)) + && (l1 <= INT_MAX) && (l1 >= INT_MIN) + && (l2 <= INT_MAX) && (l2 >= INT_MIN)) + || ((sizeof(long) >= 2*sizeof(short)) + && (l1 <= SHRT_MAX) && (l1 >= SHRT_MIN) + && (l2 <= SHRT_MAX) && (l2 >= SHRT_MIN))) { + lResult = l1 * l2; + goto longResultOfArithmetic; + } } - TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); - if (Tcl_IsShared(valuePtr)) { - objResultPtr = Tcl_NewWideIntObj(wResult); - TRACE(("%s\n", O2S(objResultPtr))); - NEXT_INST_F(1, 2, 1); - } - Tcl_SetWideIntObj(valuePtr, wResult); - TRACE(("%s\n", O2S(valuePtr))); - NEXT_INST_F(1, 1, 0); + /* + * Fall through with INST_EXPON, INST_DIV and large multiplies. + */ } overflow: TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); - Tcl_TakeBignumFromObj(NULL, valuePtr, &big1); - Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2); - mp_init(&bigResult); - switch (*pc) { - case INST_ADD: - mp_add(&big1, &big2, &bigResult); - break; - case INST_SUB: - mp_sub(&big1, &big2, &bigResult); - break; - case INST_MULT: - mp_mul(&big1, &big2, &bigResult); - break; - case INST_DIV: - if (mp_iszero(&big2)) { - TRACE(("%s %s => DIVIDE BY ZERO\n", O2S(valuePtr), - O2S(value2Ptr))); - mp_clear(&big1); - mp_clear(&big2); - mp_clear(&bigResult); - goto divideByZero; - } - mp_init(&bigRemainder); - mp_div(&big1, &big2, &bigResult, &bigRemainder); - /* TODO: internals intrusion */ - if (!mp_iszero(&bigRemainder) - && (bigRemainder.sign != big2.sign)) { - /* - * Convert to Tcl's integer division rules. - */ - - mp_sub_d(&bigResult, 1, &bigResult); - mp_add(&bigRemainder, &big2, &bigRemainder); - } - mp_clear(&bigRemainder); - break; - case INST_EXPON: - if (big2.used > 1) { - Tcl_SetResult(interp, "exponent too large", TCL_STATIC); - mp_clear(&big1); - mp_clear(&big2); - mp_clear(&bigResult); - 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))); + objResultPtr = ExecuteExtendedBinaryMathOp(interp, *pc, &TCONST(0), + valuePtr, value2Ptr); + if (objResultPtr == DIVIDED_BY_ZERO) { + TRACE_APPEND(("DIVIDE BY ZERO\n")); + goto divideByZero; + } else if (objResultPtr == EXPONENT_OF_ZERO) { + TRACE_APPEND(("EXPONENT OF ZERO\n")); + goto exponOfZero; + } else if (objResultPtr == GENERAL_ARITHMETIC_ERROR) { + TRACE_APPEND(("ERROR: %s\n", + TclGetString(Tcl_GetObjResult(interp)))); + goto gotError; + } else if (objResultPtr == NULL) { + TRACE_APPEND(("%s\n", O2S(valuePtr))); + NEXT_INST_F(1, 1, 0); + } else { + TRACE_APPEND(("%s\n", O2S(objResultPtr))); NEXT_INST_F(1, 2, 1); } - Tcl_SetBignumObj(valuePtr, &bigResult); - TRACE(("%s\n", O2S(valuePtr))); - NEXT_INST_F(1, 1, 0); case INST_LNOT: { int b; @@ -6667,11 +5392,10 @@ TclExecuteByteCode( NEXT_INST_F(1, 1, 1); } - case INST_BITNOT: + 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)) { + if ((GetNumberFromObj(NULL, valuePtr, &ptr1, &type1) != TCL_OK) + || (type1==TCL_NUMBER_NAN) || (type1==TCL_NUMBER_DOUBLE)) { /* * ... ~$NonInteger => raise an error. */ @@ -6690,45 +5414,25 @@ TclExecuteByteCode( TclSetLongObj(valuePtr, ~l1); NEXT_INST_F(1, 0, 0); } -#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); - } - 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); + objResultPtr = ExecuteExtendedUnaryMathOp(*pc, valuePtr); + if (objResultPtr != NULL) { NEXT_INST_F(1, 1, 1); + } else { + NEXT_INST_F(1, 0, 0); } - Tcl_SetBignumObj(valuePtr, &big1); - NEXT_INST_F(1, 0, 0); case INST_UMINUS: valuePtr = OBJ_AT_TOS; - TRESULT = GetNumberFromObj(NULL, valuePtr, &ptr1, &type1); - if ((TRESULT != TCL_OK) || IsErroringNaNType(type1)) { + 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_DOUBLE: - if (Tcl_IsShared(valuePtr)) { - TclNewDoubleObj(objResultPtr, -(*((const double *) ptr1))); - NEXT_INST_F(1, 1, 1); - } - d1 = *((const double *) ptr1); - TclSetDoubleObj(valuePtr, -d1); + case TCL_NUMBER_NAN: + /* -NaN => NaN */ NEXT_INST_F(1, 0, 0); case TCL_NUMBER_LONG: l1 = *((const long *) ptr1); @@ -6741,46 +5445,11 @@ TclExecuteByteCode( NEXT_INST_F(1, 0, 0); } /* FALLTHROUGH */ -#ifndef NO_WIDE_TYPE - case TCL_NUMBER_WIDE: - if (type1 == TCL_NUMBER_LONG) { - w1 = (Tcl_WideInt)(*((const long *) ptr1)); - } else { - w1 = *((const Tcl_WideInt *) ptr1); - } - if (w1 != LLONG_MIN) { - if (Tcl_IsShared(valuePtr)) { - objResultPtr = Tcl_NewWideIntObj(-w1); - NEXT_INST_F(1, 1, 1); - } - 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); - } - Tcl_SetBignumObj(valuePtr, &big1); - NEXT_INST_F(1, 0, 0); - case TCL_NUMBER_NAN: - /* -NaN => NaN */ + } + objResultPtr = ExecuteExtendedUnaryMathOp(*pc, valuePtr); + if (objResultPtr != NULL) { + NEXT_INST_F(1, 1, 1); + } else { NEXT_INST_F(1, 0, 0); } @@ -6889,17 +5558,21 @@ TclExecuteByteCode( cleanup = 0; goto processExceptionReturn; - case INST_FOREACH_START4: { + { + ForeachInfo *infoPtr; + Var *iterVarPtr, *listVarPtr; + Tcl_Obj *oldValuePtr, *listPtr, **elements; + ForeachVarList *varListPtr; + int numLists, iterNum, listTmpIndex, listLen, numVars; + int varIndex, valIndex, continueLoop, j, iterTmpIndex; + long i; + + case INST_FOREACH_START4: /* * Initialize the temporary local var that holds the count of the * number of iterations of the loop body to -1. */ - int iterTmpIndex; - ForeachInfo *infoPtr; - Var *iterVarPtr; - Tcl_Obj *oldValuePtr; - opnd = TclGetUInt4AtPtr(pc+1); infoPtr = codePtr->auxDataArrayPtr[opnd].clientData; iterTmpIndex = infoPtr->loopCtTemp; @@ -6926,22 +5599,13 @@ TclExecuteByteCode( #else NEXT_INST_F(5, 0, 0); #endif - } - case INST_FOREACH_STEP4: { + case INST_FOREACH_STEP4: /* * "Step" a foreach loop (i.e., begin its next iteration) by assigning * the next value list element to each loop var. */ - ForeachInfo *infoPtr; - ForeachVarList *varListPtr; - Tcl_Obj *listPtr, **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; @@ -6952,7 +5616,7 @@ TclExecuteByteCode( iterVarPtr = LOCAL(infoPtr->loopCtTemp); valuePtr = iterVarPtr->value.objPtr; - iterNum = (valuePtr->internalRep.longValue + 1); + iterNum = valuePtr->internalRep.longValue + 1; TclSetLongObj(valuePtr, iterNum); /* @@ -6968,13 +5632,11 @@ TclExecuteByteCode( 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; } @@ -7024,16 +5686,16 @@ TclExecuteByteCode( } } else { DECACHE_STACK_INFO(); - value2Ptr = TclPtrSetVar(interp, varPtr, NULL, NULL, - NULL, valuePtr, TCL_LEAVE_ERR_MSG, varIndex); - CACHE_STACK_INFO(); - if (value2Ptr == NULL) { + if (TclPtrSetVar(interp, varPtr, NULL, NULL, NULL, + valuePtr, TCL_LEAVE_ERR_MSG, varIndex)==NULL){ + CACHE_STACK_INFO(); TRACE_WITH_OBJ(( "%u => ERROR init. index temp %d: ", opnd,varIndex), Tcl_GetObjResult(interp)); TclDecrRefCount(listPtr); goto gotError; } + CACHE_STACK_INFO(); } valIndex++; } @@ -7143,20 +5805,20 @@ TclExecuteByteCode( 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 { + 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; @@ -7233,7 +5895,7 @@ TclExecuteByteCode( } TRACE_WITH_OBJ(("%u %u => ERROR updating dictionary: ", opnd, opnd2), Tcl_GetObjResult(interp)); - goto gotError; + goto checkForCatch; } if (TclIsVarDirectWritable(varPtr)) { @@ -7270,7 +5932,6 @@ TclExecuteByteCode( case INST_DICT_APPEND: case INST_DICT_LAPPEND: opnd = TclGetUInt4AtPtr(pc+1); - varPtr = LOCAL(opnd); while (TclIsVarLink(varPtr)) { varPtr = varPtr->value.linkPtr; @@ -7311,12 +5972,12 @@ TclExecuteByteCode( 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); - } + } 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); } break; case INST_DICT_LAPPEND: @@ -7325,8 +5986,9 @@ TclExecuteByteCode( */ if (valuePtr == NULL) { - valuePtr = Tcl_NewListObj(1, &OBJ_AT_TOS); - Tcl_DictObjPut(NULL, dictPtr, OBJ_UNDER_TOS, valuePtr); + 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, @@ -7388,8 +6050,8 @@ TclExecuteByteCode( TRACE(("%u => ", opnd)); dictPtr = POP_OBJECT(); searchPtr = (Tcl_DictSearch *) ckalloc(sizeof(Tcl_DictSearch)); - if (Tcl_DictObjFirst(interp, dictPtr, searchPtr, &keyPtr, &valuePtr, - &done) != TCL_OK) { + if (Tcl_DictObjFirst(interp, dictPtr, searchPtr, &keyPtr, + &valuePtr, &done) != TCL_OK) { ckfree((char *) searchPtr); goto gotError; } @@ -7596,28 +6258,6 @@ TclExecuteByteCode( } /* end of switch on opCode */ /* - * Division by zero in an expression. Control only reaches this point by - * "goto divideByZero". - */ - - divideByZero: - Tcl_SetResult(interp, "divide by zero", TCL_STATIC); - Tcl_SetErrorCode(interp, "ARITH", "DIVZERO", "divide by zero", NULL); - goto gotError; - - /* - * Exponentiation of zero by negative number in an expression. Control - * only reaches this point by "goto exponOfZero". - */ - - 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; - - /* * Block for variables needed to process exception returns. */ @@ -7680,13 +6320,12 @@ TclExecuteByteCode( 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", + } + 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", @@ -7709,6 +6348,35 @@ TclExecuteByteCode( goto checkForCatch; /* + * Division by zero in an expression. Control only reaches this point + * by "goto divideByZero". + */ + + divideByZero: + Tcl_SetResult(interp, "divide by zero", TCL_STATIC); + Tcl_SetErrorCode(interp, "ARITH", "DIVZERO", "divide by zero", NULL); + goto gotError; + + /* + * Exponentiation of zero by negative number in an expression. Control + * only reaches this point by "goto exponOfZero". + */ + + exponOfZero: + Tcl_SetResult(interp, "exponentiation of zero by negative power", + TCL_STATIC); + Tcl_SetErrorCode(interp, "ARITH", "DOMAIN", + "exponentiation of zero by negative power", NULL); + + /* + * Almost all error paths feed through here rather than assigning to + * TRESULT themselves (for a small but consistent saving). + */ + + gotError: + TRESULT = TCL_ERROR; + + /* * Execution has generated an "exception" such as TCL_ERROR. If the * exception is an error, record information about what was being * executed when the error occurred. Find the closest enclosing catch @@ -7716,8 +6384,6 @@ TclExecuteByteCode( * and return the "exception" code. */ - gotError: - TRESULT = TCL_ERROR; checkForCatch: if (iPtr->execEnvPtr->rewind) { goto abnormalReturn; @@ -7947,6 +6613,1361 @@ TclExecuteByteCode( #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; + } + if ((l2 == 1) || (l2 == -1)) { + /* + * Div. by |1| always yields remainder of 0. + */ + + return constants[0]; + } + } +#ifndef NO_WIDE_TYPE + if (type1 == TCL_NUMBER_WIDE) { + w1 = *((const Tcl_WideInt *)ptr1); + if (type2 != TCL_NUMBER_BIG) { + Tcl_GetWideIntFromObj(NULL, value2Ptr, &w2); + wQuotient = w1 / w2; + + /* + * Force Tcl's integer division rules. + * TODO: examine for logic simplification + */ + + if (((wQuotient < (Tcl_WideInt) 0) + || ((wQuotient == (Tcl_WideInt) 0) + && ((w1 < (Tcl_WideInt)0 && w2 > (Tcl_WideInt)0) + || (w1 > (Tcl_WideInt)0 && w2 < (Tcl_WideInt)0)))) + && (wQuotient * w2 != w1)) { + wQuotient -= (Tcl_WideInt) 1; + } + wRemainder = w1 - w2*wQuotient; + WIDE_RESULT(wRemainder); + } + + Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2); + + /* TODO: internals intrusion */ + if ((w1 > ((Tcl_WideInt) 0)) ^ (big2.sign == MP_ZPOS)) { + /* + * Arguments are opposite sign; remainder is sum. + */ + + TclBNInitBignumFromWideInt(&big1, w1); + mp_add(&big2, &big1, &big2); + mp_clear(&big1); + BIG_RESULT(&big2); + } + + /* + * Arguments are same sign; remainder is first operand. + */ + + mp_clear(&big2); + return NULL; + } +#endif + Tcl_GetBignumFromObj(NULL, valuePtr, &big1); + Tcl_GetBignumFromObj(NULL, value2Ptr, &big2); + mp_init(&bigResult); + mp_init(&bigRemainder); + mp_div(&big1, &big2, &bigResult, &bigRemainder); + if (!mp_iszero(&bigRemainder) && (bigRemainder.sign != big2.sign)) { + /* + * Convert to Tcl's integer division rules. + */ + + mp_sub_d(&bigResult, 1, &bigResult); + mp_add(&bigRemainder, &big2, &bigRemainder); + } + mp_copy(&bigRemainder, &bigResult); + mp_clear(&bigRemainder); + mp_clear(&big1); + mp_clear(&big2); + BIG_RESULT(&bigResult); + + case INST_LSHIFT: + case INST_RSHIFT: { + /* + * Reject negative shift argument. + */ + + switch (type2) { + case TCL_NUMBER_LONG: + invalid = (*((const long *)ptr2) < 0L); + break; +#ifndef NO_WIDE_TYPE + case TCL_NUMBER_WIDE: + invalid = (*((const Tcl_WideInt *)ptr2) < (Tcl_WideInt)0); + break; +#endif + case TCL_NUMBER_BIG: + Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2); + invalid = (mp_cmp_d(&big2, 0) == MP_LT); + mp_clear(&big2); + break; + default: + /* Unused, here to silence compiler warning */ + invalid = 0; + } + if (invalid) { + Tcl_SetResult(interp, "negative shift argument", TCL_STATIC); + return GENERAL_ARITHMETIC_ERROR; + } + + /* + * Zero shifted any number of bits is still zero. + */ + + if ((type1==TCL_NUMBER_LONG) && (*((const long *)ptr1) == (long)0)) { + return constants[0]; + } + + if (opcode == INST_LSHIFT) { + /* + * Large left shifts create integer overflow. + * + * BEWARE! Can't use Tcl_GetIntFromObj() here because that + * converts values in the (unsigned) range to their signed int + * counterparts, leading to incorrect results. + */ + + if ((type2 != TCL_NUMBER_LONG) + || (*((const long *)ptr2) > (long) INT_MAX)) { + /* + * Technically, we could hold the value (1 << (INT_MAX+1)) in + * an mp_int, but since we're using mp_mul_2d() to do the + * work, and it takes only an int argument, that's a good + * place to draw the line. + */ + + Tcl_SetResult(interp, "integer value too large to represent", + TCL_STATIC); + return GENERAL_ARITHMETIC_ERROR; + } + shift = (int)(*((const long *)ptr2)); + + /* + * Handle shifts within the native wide range. + */ + + if ((type1 != TCL_NUMBER_BIG) + && ((size_t)shift < CHAR_BIT*sizeof(Tcl_WideInt))) { + TclGetWideIntFromObj(NULL, valuePtr, &w1); + if (!((w1>0 ? w1 : ~w1) + & -(((Tcl_WideInt)1) + << (CHAR_BIT*sizeof(Tcl_WideInt) - 1 - shift)))) { + WIDE_RESULT(w1 << shift); + } + } + } else { + /* + * Quickly force large right shifts to 0 or -1. + */ + + if ((type2 != TCL_NUMBER_LONG) + || (*(const long *)ptr2 > INT_MAX)) { + /* + * Again, technically, the value to be shifted could be an + * mp_int so huge that a right shift by (INT_MAX+1) bits could + * not take us to the result of 0 or -1, but since we're using + * mp_div_2d to do the work, and it takes only an int + * argument, we draw the line there. + */ + + switch (type1) { + case TCL_NUMBER_LONG: + zero = (*(const long *)ptr1 > 0L); + break; +#ifndef NO_WIDE_TYPE + case TCL_NUMBER_WIDE: + zero = (*(const Tcl_WideInt *)ptr1 > (Tcl_WideInt)0); + break; +#endif + case TCL_NUMBER_BIG: + Tcl_TakeBignumFromObj(NULL, valuePtr, &big1); + zero = (mp_cmp_d(&big1, 0) == MP_GT); + mp_clear(&big1); + break; + default: + /* Unused, here to silence compiler warning. */ + zero = 0; + } + if (zero) { + return constants[0]; + } + LONG_RESULT(-1); + } + shift = (int)(*(const long *)ptr2); + +#ifndef NO_WIDE_TYPE + /* + * Handle shifts within the native wide range. + */ + + if (type1 == TCL_NUMBER_WIDE) { + w1 = *(const Tcl_WideInt *)ptr1; + if ((size_t)shift >= CHAR_BIT*sizeof(Tcl_WideInt)) { + if (w1 >= (Tcl_WideInt)0) { + return constants[0]; + } + LONG_RESULT(-1); + } + WIDE_RESULT(w1 >> shift); + } +#endif + } + + Tcl_TakeBignumFromObj(NULL, valuePtr, &big1); + + mp_init(&bigResult); + if (opcode == INST_LSHIFT) { + mp_mul_2d(&big1, shift, &bigResult); + } else { + mp_init(&bigRemainder); + mp_div_2d(&big1, shift, &bigResult, &bigRemainder); + if (mp_cmp_d(&bigRemainder, 0) == MP_LT) { + /* + * Convert to Tcl's integer division rules. + */ + + mp_sub_d(&bigResult, 1, &bigResult); + } + mp_clear(&bigRemainder); + } + mp_clear(&big1); + BIG_RESULT(&bigResult); + } + + case INST_BITOR: + case INST_BITXOR: + case INST_BITAND: + if ((type1 == TCL_NUMBER_BIG) || (type2 == TCL_NUMBER_BIG)) { + mp_int *First, *Second; + + Tcl_TakeBignumFromObj(NULL, valuePtr, &big1); + Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2); + + /* + * Count how many positive arguments we have. If only one of the + * arguments is negative, store it in 'Second'. + */ + + if (mp_cmp_d(&big1, 0) != MP_LT) { + numPos = 1 + (mp_cmp_d(&big2, 0) != MP_LT); + First = &big1; + Second = &big2; + } else { + First = &big2; + Second = &big1; + numPos = (mp_cmp_d(First, 0) != MP_LT); + } + mp_init(&bigResult); + + switch (opcode) { + case INST_BITAND: + switch (numPos) { + case 2: + /* + * Both arguments positive, base case. + */ + + mp_and(First, Second, &bigResult); + break; + case 1: + /* + * First is positive; second negative: + * P & N = P & ~~N = P&~(-N-1) = P & (P ^ (-N-1)) + */ + + mp_neg(Second, Second); + mp_sub_d(Second, 1, Second); + mp_xor(First, Second, &bigResult); + mp_and(First, &bigResult, &bigResult); + break; + case 0: + /* + * Both arguments negative: + * a & b = ~ (~a | ~b) = -(-a-1|-b-1)-1 + */ + + mp_neg(First, First); + mp_sub_d(First, 1, First); + mp_neg(Second, Second); + mp_sub_d(Second, 1, Second); + mp_or(First, Second, &bigResult); + mp_neg(&bigResult, &bigResult); + mp_sub_d(&bigResult, 1, &bigResult); + break; + } + break; + + case INST_BITOR: + switch (numPos) { + case 2: + /* + * Both arguments positive, base case. + */ + + mp_or(First, Second, &bigResult); + break; + case 1: + /* + * First is positive; second negative: + * N|P = ~(~N&~P) = ~((-N-1)&~P) = -((-N-1)&((-N-1)^P))-1 + */ + + mp_neg(Second, Second); + mp_sub_d(Second, 1, Second); + mp_xor(First, Second, &bigResult); + mp_and(Second, &bigResult, &bigResult); + mp_neg(&bigResult, &bigResult); + mp_sub_d(&bigResult, 1, &bigResult); + break; + case 0: + /* + * Both arguments negative: + * a | b = ~ (~a & ~b) = -(-a-1&-b-1)-1 + */ + + mp_neg(First, First); + mp_sub_d(First, 1, First); + mp_neg(Second, Second); + mp_sub_d(Second, 1, Second); + mp_and(First, Second, &bigResult); + mp_neg(&bigResult, &bigResult); + mp_sub_d(&bigResult, 1, &bigResult); + break; + } + break; + + case INST_BITXOR: + switch (numPos) { + case 2: + /* + * Both arguments positive, base case. + */ + + mp_xor(First, Second, &bigResult); + break; + case 1: + /* + * First is positive; second negative: + * P^N = ~(P^~N) = -(P^(-N-1))-1 + */ + + mp_neg(Second, Second); + mp_sub_d(Second, 1, Second); + mp_xor(First, Second, &bigResult); + mp_neg(&bigResult, &bigResult); + mp_sub_d(&bigResult, 1, &bigResult); + break; + case 0: + /* + * Both arguments negative: + * a ^ b = (~a ^ ~b) = (-a-1^-b-1) + */ + + mp_neg(First, First); + mp_sub_d(First, 1, First); + mp_neg(Second, Second); + mp_sub_d(Second, 1, Second); + mp_xor(First, Second, &bigResult); + break; + } + break; + } + + mp_clear(&big1); + mp_clear(&big2); + BIG_RESULT(&bigResult); + } + +#ifndef NO_WIDE_TYPE + if ((type1 == TCL_NUMBER_WIDE) || (type2 == TCL_NUMBER_WIDE)) { + TclGetWideIntFromObj(NULL, valuePtr, &w1); + TclGetWideIntFromObj(NULL, value2Ptr, &w2); + + switch (opcode) { + case INST_BITAND: + wResult = w1 & w2; + break; + case INST_BITOR: + wResult = w1 | w2; + break; + case INST_BITXOR: + wResult = w1 ^ w2; + break; + default: + /* Unused, here to silence compiler warning. */ + wResult = 0; + } + WIDE_RESULT(wResult); + } +#endif + l1 = *((const long *)ptr1); + l2 = *((const long *)ptr2); + + switch (opcode) { + case INST_BITAND: + lResult = l1 & l2; + break; + case INST_BITOR: + lResult = l1 | l2; + break; + case INST_BITXOR: + lResult = l1 ^ l2; + break; + default: + /* Unused, here to silence compiler warning. */ + lResult = 0; + } + LONG_RESULT(lResult); + + case INST_EXPON: { + int oddExponent = 0, negativeExponent = 0; + unsigned short base; + + if ((type1 == TCL_NUMBER_DOUBLE) || (type2 == TCL_NUMBER_DOUBLE)) { + Tcl_GetDoubleFromObj(NULL, valuePtr, &d1); + Tcl_GetDoubleFromObj(NULL, value2Ptr, &d2); + + if (d1==0.0 && d2<0.0) { + return EXPONENT_OF_ZERO; + } + dResult = pow(d1, d2); + goto doubleResult; + } + l1 = l2 = 0; + if (type2 == TCL_NUMBER_LONG) { + l2 = *((const long *) ptr2); + if (l2 == 0) { + /* + * Anything to the zero power is 1. + */ + + return constants[1]; + } else if (l2 == 1) { + /* + * Anything to the first power is itself + */ + + return NULL; + } + } + + switch (type2) { + case TCL_NUMBER_LONG: + negativeExponent = (l2 < 0); + oddExponent = (int) (l2 & 1); + break; +#ifndef NO_WIDE_TYPE + case TCL_NUMBER_WIDE: + w2 = *((const Tcl_WideInt *)ptr2); + negativeExponent = (w2 < 0); + oddExponent = (int) (w2 & (Tcl_WideInt)1); + break; +#endif + case TCL_NUMBER_BIG: + Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2); + negativeExponent = (mp_cmp_d(&big2, 0) == MP_LT); + mp_mod_2d(&big2, 1, &big2); + oddExponent = !mp_iszero(&big2); + mp_clear(&big2); + break; + } + + if (type1 == TCL_NUMBER_LONG) { + l1 = *((const long *)ptr1); + } + if (negativeExponent) { + if (type1 == TCL_NUMBER_LONG) { + switch (l1) { + case 0: + /* + * Zero to a negative power is div by zero error. + */ + + return EXPONENT_OF_ZERO; + case -1: + if (oddExponent) { + LONG_RESULT(-1); + } + /* fallthrough */ + case 1: + /* + * 1 to any power is 1. + */ + + return constants[1]; + } + } + + /* + * Integers with magnitude greater than 1 raise to a negative + * power yield the answer zero (see TIP 123). + */ + + return constants[0]; + } + + if (type1 == TCL_NUMBER_LONG) { + switch (l1) { + case 0: + /* + * Zero to a positive power is zero. + */ + + return constants[0]; + case 1: + /* + * 1 to any power is 1. + */ + + return constants[1]; + case -1: + if (!oddExponent) { + return constants[1]; + } + LONG_RESULT(-1); + } + } + + /* + * We refuse to accept exponent arguments that exceed one mp_digit + * which means the max exponent value is 2**28-1 = 0x0fffffff = + * 268435455, which fits into a signed 32 bit int which is within the + * range of the long int type. This means any numeric Tcl_Obj value + * not using TCL_NUMBER_LONG type must hold a value larger than we + * accept. + */ + + if (type2 != TCL_NUMBER_LONG) { + Tcl_SetResult(interp, "exponent too large", TCL_STATIC); + return GENERAL_ARITHMETIC_ERROR; + } + + if (type1 == TCL_NUMBER_LONG) { + if (l1 == 2) { + /* + * Reduce small powers of 2 to shifts. + */ + + if ((unsigned long) l2 < CHAR_BIT * sizeof(long) - 1) { + LONG_RESULT(1L << l2); + } +#if !defined(TCL_WIDE_INT_IS_LONG) + if ((unsigned long)l2 < CHAR_BIT*sizeof(Tcl_WideInt) - 1) { + WIDE_RESULT(((Tcl_WideInt) 1) << l2); + } +#endif + goto overflowExpon; + } + if (l1 == -2) { + int signum = oddExponent ? -1 : 1; + + /* + * Reduce small powers of 2 to shifts. + */ + + if ((unsigned long) l2 < CHAR_BIT * sizeof(long) - 1) { + LONG_RESULT(signum * (1L << l2)); + } +#if !defined(TCL_WIDE_INT_IS_LONG) + if ((unsigned long)l2 < CHAR_BIT*sizeof(Tcl_WideInt) - 1){ + WIDE_RESULT(signum * (((Tcl_WideInt) 1) << l2)); + } +#endif + goto overflowExpon; + } +#if (LONG_MAX == 0x7fffffff) + if (l2 - 2 < (long)MaxBase32Size + && l1 <= MaxBase32[l2 - 2] + && l1 >= -MaxBase32[l2 - 2]) { + /* + * Small powers of 32-bit integers. + */ + + lResult = l1 * l1; /* b**2 */ + switch (l2) { + case 2: + break; + case 3: + lResult *= l1; /* b**3 */ + break; + case 4: + lResult *= lResult; /* b**4 */ + break; + case 5: + lResult *= lResult; /* b**4 */ + lResult *= l1; /* b**5 */ + break; + case 6: + lResult *= l1; /* b**3 */ + lResult *= lResult; /* b**6 */ + break; + case 7: + lResult *= l1; /* b**3 */ + lResult *= lResult; /* b**6 */ + lResult *= l1; /* b**7 */ + break; + case 8: + lResult *= lResult; /* b**4 */ + lResult *= lResult; /* b**8 */ + break; + } + LONG_RESULT(lResult); + } + + if (l1 - 3 >= 0 && l1 -2 < (long)Exp32IndexSize + && l2 - 2 < (long)(Exp32ValueSize + MaxBase32Size)) { + base = Exp32Index[l1 - 3] + + (unsigned short) (l2 - 2 - MaxBase32Size); + if (base < Exp32Index[l1 - 2]) { + /* + * 32-bit number raised to intermediate power, done by + * table lookup. + */ + + LONG_RESULT(Exp32Value[base]); + } + } + if (-l1 - 3 >= 0 && -l1 - 2 < (long)Exp32IndexSize + && l2 - 2 < (long)(Exp32ValueSize + MaxBase32Size)) { + base = Exp32Index[-l1 - 3] + + (unsigned short) (l2 - 2 - MaxBase32Size); + if (base < Exp32Index[-l1 - 2]) { + /* + * 32-bit number raised to intermediate power, done by + * table lookup. + */ + + lResult = (oddExponent) ? + -Exp32Value[base] : Exp32Value[base]; + LONG_RESULT(lResult); + } + } +#endif + } +#if (LONG_MAX > 0x7fffffff) || !defined(TCL_WIDE_INT_IS_LONG) + if (type1 == TCL_NUMBER_LONG) { + w1 = l1; +#ifndef NO_WIDE_TYPE + } else if (type1 == TCL_NUMBER_WIDE) { + w1 = *((const Tcl_WideInt *) ptr1); +#endif + } else { + goto overflowExpon; + } + if (l2 - 2 < (long)MaxBase64Size + && w1 <= MaxBase64[l2 - 2] + && w1 >= -MaxBase64[l2 - 2]) { + /* + * Small powers of integers whose result is wide. + */ + + wResult = w1 * w1; /* b**2 */ + switch (l2) { + case 2: + break; + case 3: + wResult *= l1; /* b**3 */ + break; + case 4: + wResult *= wResult; /* b**4 */ + break; + case 5: + wResult *= wResult; /* b**4 */ + wResult *= w1; /* b**5 */ + break; + case 6: + wResult *= w1; /* b**3 */ + wResult *= wResult; /* b**6 */ + break; + case 7: + wResult *= w1; /* b**3 */ + wResult *= wResult; /* b**6 */ + wResult *= w1; /* b**7 */ + break; + case 8: + wResult *= wResult; /* b**4 */ + wResult *= wResult; /* b**8 */ + break; + case 9: + wResult *= wResult; /* b**4 */ + wResult *= wResult; /* b**8 */ + wResult *= w1; /* b**9 */ + break; + case 10: + wResult *= wResult; /* b**4 */ + wResult *= w1; /* b**5 */ + wResult *= wResult; /* b**10 */ + break; + case 11: + wResult *= wResult; /* b**4 */ + wResult *= w1; /* b**5 */ + wResult *= wResult; /* b**10 */ + wResult *= w1; /* b**11 */ + break; + case 12: + wResult *= w1; /* b**3 */ + wResult *= wResult; /* b**6 */ + wResult *= wResult; /* b**12 */ + break; + case 13: + wResult *= w1; /* b**3 */ + wResult *= wResult; /* b**6 */ + wResult *= wResult; /* b**12 */ + wResult *= w1; /* b**13 */ + break; + case 14: + wResult *= w1; /* b**3 */ + wResult *= wResult; /* b**6 */ + wResult *= w1; /* b**7 */ + wResult *= wResult; /* b**14 */ + break; + case 15: + wResult *= w1; /* b**3 */ + wResult *= wResult; /* b**6 */ + wResult *= w1; /* b**7 */ + wResult *= wResult; /* b**14 */ + wResult *= w1; /* b**15 */ + break; + case 16: + wResult *= wResult; /* b**4 */ + wResult *= wResult; /* b**8 */ + wResult *= wResult; /* b**16 */ + break; + } + WIDE_RESULT(wResult); + } + + /* + * Handle cases of powers > 16 that still fit in a 64-bit word by + * doing table lookup. + */ + + if (w1 - 3 >= 0 && w1 - 2 < (long)Exp64IndexSize + && l2 - 2 < (long)(Exp64ValueSize + MaxBase64Size)) { + base = Exp64Index[w1 - 3] + + (unsigned short) (l2 - 2 - MaxBase64Size); + if (base < Exp64Index[w1 - 2]) { + /* + * 64-bit number raised to intermediate power, done by + * table lookup. + */ + + WIDE_RESULT(Exp64Value[base]); + } + } + + if (-w1 - 3 >= 0 && -w1 - 2 < (long)Exp64IndexSize + && l2 - 2 < (long)(Exp64ValueSize + MaxBase64Size)) { + base = Exp64Index[-w1 - 3] + + (unsigned short) (l2 - 2 - MaxBase64Size); + if (base < Exp64Index[-w1 - 2]) { + /* + * 64-bit number raised to intermediate power, done by + * table lookup. + */ + + wResult = oddExponent ? -Exp64Value[base] : Exp64Value[base]; + WIDE_RESULT(wResult); + } + } +#endif + + 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); + } + + case INST_ADD: + case INST_SUB: + case INST_MULT: + case INST_DIV: + if ((type1 == TCL_NUMBER_DOUBLE) || (type2 == TCL_NUMBER_DOUBLE)) { + /* + * At least one of the values is floating-point, so perform + * floating point calculations. + */ + + Tcl_GetDoubleFromObj(NULL, valuePtr, &d1); + Tcl_GetDoubleFromObj(NULL, value2Ptr, &d2); + + switch (opcode) { + case INST_ADD: + dResult = d1 + d2; + break; + case INST_SUB: + dResult = d1 - d2; + break; + case INST_MULT: + dResult = d1 * d2; + break; + case INST_DIV: +#ifndef IEEE_FLOATING_POINT + if (d2 == 0.0) { + return DIVIDED_BY_ZERO; + } +#endif + /* + * We presume that we are running with zero-divide unmasked if + * we're on an IEEE box. Otherwise, this statement might cause + * demons to fly out our noses. + */ + + dResult = d1 / d2; + break; + default: + /* Unused, here to silence compiler warning. */ + dResult = 0; + } + + doubleResult: +#ifndef ACCEPT_NAN + /* + * Check now for IEEE floating-point error. + */ + + if (TclIsNaN(dResult)) { + TclExprFloatError(interp, dResult); + return GENERAL_ARITHMETIC_ERROR; + } +#endif + DOUBLE_RESULT(dResult); + } + if ((type1 != TCL_NUMBER_BIG) && (type2 != TCL_NUMBER_BIG)) { + TclGetWideIntFromObj(NULL, valuePtr, &w1); + TclGetWideIntFromObj(NULL, value2Ptr, &w2); + + switch (opcode) { + case INST_ADD: + wResult = w1 + w2; +#ifndef NO_WIDE_TYPE + if ((type1 == TCL_NUMBER_WIDE) || (type2 == TCL_NUMBER_WIDE)) +#endif + { + /* + * Check for overflow. + */ + + if (Overflowing(w1, w2, wResult)) { + goto overflowBasic; + } + } + break; + + case INST_SUB: + wResult = w1 - w2; +#ifndef NO_WIDE_TYPE + if ((type1 == TCL_NUMBER_WIDE) || (type2 == TCL_NUMBER_WIDE)) +#endif + { + /* + * Must check for overflow. The macro tests for overflows + * in sums by looking at the sign bits. As we have a + * subtraction here, we are adding -w2. As -w2 could in + * turn overflow, we test with ~w2 instead: it has the + * opposite sign bit to w2 so it does the job. Note that + * the only "bad" case (w2==0) is irrelevant for this + * macro, as in that case w1 and wResult have the same + * sign and there is no overflow anyway. + */ + + if (Overflowing(w1, ~w2, wResult)) { + goto overflowBasic; + } + } + break; + + case INST_MULT: + if ((type1 != TCL_NUMBER_LONG) || (type2 != TCL_NUMBER_LONG) + || (sizeof(Tcl_WideInt) < 2*sizeof(long))) { + goto overflowBasic; + } + wResult = w1 * w2; + break; + + case INST_DIV: + if (w2 == 0) { + return DIVIDED_BY_ZERO; + } + + /* + * Need a bignum to represent (LLONG_MIN / -1) + */ + + if ((w1 == LLONG_MIN) && (w2 == -1)) { + goto overflowBasic; + } + wResult = w1 / w2; + + /* + * Force Tcl's integer division rules. + * TODO: examine for logic simplification + */ + + if (((wResult < 0) || ((wResult == 0) && + ((w1 < 0 && w2 > 0) || (w1 > 0 && w2 < 0)))) && + (wResult*w2 != w1)) { + wResult -= 1; + } + break; + + default: + /* + * Unused, here to silence compiler warning. + */ + + wResult = 0; + } + + WIDE_RESULT(wResult); + } + + overflowBasic: + Tcl_TakeBignumFromObj(NULL, valuePtr, &big1); + Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2); + mp_init(&bigResult); + switch (opcode) { + case INST_ADD: + mp_add(&big1, &big2, &bigResult); + break; + case INST_SUB: + mp_sub(&big1, &big2, &bigResult); + break; + case INST_MULT: + mp_mul(&big1, &big2, &bigResult); + break; + case INST_DIV: + if (mp_iszero(&big2)) { + mp_clear(&big1); + mp_clear(&big2); + mp_clear(&bigResult); + return DIVIDED_BY_ZERO; + } + mp_init(&bigRemainder); + mp_div(&big1, &big2, &bigResult, &bigRemainder); + /* TODO: internals intrusion */ + if (!mp_iszero(&bigRemainder) + && (bigRemainder.sign != big2.sign)) { + /* + * Convert to Tcl's integer division rules. + */ + + mp_sub_d(&bigResult, 1, &bigResult); + mp_add(&bigRemainder, &big2, &bigRemainder); + } + mp_clear(&bigRemainder); + break; + } + mp_clear(&big1); + mp_clear(&big2); + BIG_RESULT(&bigResult); + } + + Tcl_Panic("unexpected opcode"); + return NULL; +} + +static Tcl_Obj * +ExecuteExtendedUnaryMathOp( + int opcode, /* What operation to perform. */ + Tcl_Obj *valuePtr) /* The operand on the stack. */ +{ + ClientData ptr; + int type; + Tcl_WideInt w; + mp_int big; + Tcl_Obj *objResultPtr; + + (void) GetNumberFromObj(NULL, valuePtr, &ptr, &type); + + switch (opcode) { + case INST_BITNOT: +#ifndef NO_WIDE_TYPE + if (type == TCL_NUMBER_WIDE) { + w = *((const Tcl_WideInt *) ptr); + WIDE_RESULT(~w); + } +#endif + Tcl_TakeBignumFromObj(NULL, valuePtr, &big); + /* ~a = - a - 1 */ + mp_neg(&big, &big); + mp_sub_d(&big, 1, &big); + BIG_RESULT(&big); + case INST_UMINUS: + switch (type) { + case TCL_NUMBER_DOUBLE: + DOUBLE_RESULT(-(*((const double *) ptr))); + case TCL_NUMBER_LONG: + w = (Tcl_WideInt) (*((const long *) ptr)); + if (w != LLONG_MIN) { + WIDE_RESULT(-w); + } + TclBNInitBignumFromLong(&big, *(const long *) ptr); + break; +#ifndef NO_WIDE_TYPE + case TCL_NUMBER_WIDE: + w = *((const Tcl_WideInt *) ptr); + if (w != LLONG_MIN) { + WIDE_RESULT(-w); + } + TclBNInitBignumFromWideInt(&big, w); + break; +#endif + default: + Tcl_TakeBignumFromObj(NULL, valuePtr, &big); + } + mp_neg(&big, &big); + BIG_RESULT(&big); + } + + Tcl_Panic("unexpected opcode"); + return NULL; +} +#undef LONG_RESULT +#undef WIDE_RESULT +#undef BIG_RESULT +#undef DOUBLE_RESULT + +/* + *---------------------------------------------------------------------- + * + * CompareTwoNumbers -- + * + * This function compares a pair of numbers in Tcl_Objs. Each argument + * must already be known to be numeric and not NaN. + * + * Results: + * One of MP_LT, MP_EQ or MP_GT, depending on whether valuePtr is less + * than, equal to, or greater than value2Ptr (respectively). + * + * Side effects: + * None, provided both values are numeric. + * + *---------------------------------------------------------------------- + */ + +int +TclCompareTwoNumbers( + Tcl_Obj *valuePtr, + Tcl_Obj *value2Ptr) +{ + int type1, type2, compare; + ClientData ptr1, ptr2; + mp_int big1, big2; + double d1, d2, tmp; + long l1, l2; + Tcl_WideInt w1, w2; + + (void) GetNumberFromObj(NULL, valuePtr, &ptr1, &type1); + (void) GetNumberFromObj(NULL, value2Ptr, &ptr2, &type2); + + switch (type1) { + case TCL_NUMBER_LONG: + l1 = *((const long *)ptr1); + switch (type2) { + case TCL_NUMBER_LONG: + l2 = *((const long *)ptr2); + longCompare: + return (l1 < l2) ? MP_LT : ((l1 > l2) ? MP_GT : MP_EQ); +#ifndef NO_WIDE_TYPE + case TCL_NUMBER_WIDE: + w2 = *((const Tcl_WideInt *)ptr2); + w1 = (Tcl_WideInt)l1; + goto wideCompare; +#endif + case TCL_NUMBER_DOUBLE: + d2 = *((const double *)ptr2); + d1 = (double) l1; + + /* + * If the double has a fractional part, or if the long can be + * converted to double without loss of precision, then compare as + * doubles. + */ + + if (DBL_MANT_DIG > CHAR_BIT*sizeof(long) || l1 == (long) d1 + || modf(d2, &tmp) != 0.0) { + goto doubleCompare; + } + + /* + * Otherwise, to make comparision based on full precision, need to + * convert the double to a suitably sized integer. + * + * Need this to get comparsions like + * expr 20000000000000003 < 20000000000000004.0 + * right. Converting the first argument to double will yield two + * double values that are equivalent within double precision. + * Converting the double to an integer gets done exactly, then + * integer comparison can tell the difference. + */ + + if (d2 < (double)LONG_MIN) { + return MP_GT; + } + if (d2 > (double)LONG_MAX) { + return MP_LT; + } + l2 = (long) d2; + goto longCompare; + case TCL_NUMBER_BIG: + Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2); + if (mp_cmp_d(&big2, 0) == MP_LT) { + compare = MP_GT; + } else { + compare = MP_LT; + } + mp_clear(&big2); + return compare; + } + +#ifndef NO_WIDE_TYPE + case TCL_NUMBER_WIDE: + w1 = *((const Tcl_WideInt *)ptr1); + switch (type2) { + case TCL_NUMBER_WIDE: + w2 = *((const Tcl_WideInt *)ptr2); + wideCompare: + return (w1 < w2) ? MP_LT : ((w1 > w2) ? MP_GT : MP_EQ); + case TCL_NUMBER_LONG: + l2 = *((const long *)ptr2); + w2 = (Tcl_WideInt)l2; + goto wideCompare; + case TCL_NUMBER_DOUBLE: + d2 = *((const double *)ptr2); + d1 = (double) w1; + if (DBL_MANT_DIG > CHAR_BIT*sizeof(Tcl_WideInt) + || w1 == (Tcl_WideInt) d1 || modf(d2, &tmp) != 0.0) { + goto doubleCompare; + } + if (d2 < (double)LLONG_MIN) { + return MP_GT; + } + if (d2 > (double)LLONG_MAX) { + return MP_LT; + } + w2 = (Tcl_WideInt) d2; + goto wideCompare; + case TCL_NUMBER_BIG: + Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2); + if (mp_cmp_d(&big2, 0) == MP_LT) { + compare = MP_GT; + } else { + compare = MP_LT; + } + mp_clear(&big2); + return compare; + } +#endif + + case TCL_NUMBER_DOUBLE: + d1 = *((const double *)ptr1); + switch (type2) { + case TCL_NUMBER_DOUBLE: + d2 = *((const double *)ptr2); + doubleCompare: + return (d1 < d2) ? MP_LT : ((d1 > d2) ? MP_GT : MP_EQ); + case TCL_NUMBER_LONG: + l2 = *((const long *)ptr2); + d2 = (double) l2; + if (DBL_MANT_DIG > CHAR_BIT*sizeof(long) || l2 == (long) d2 + || modf(d1, &tmp) != 0.0) { + goto doubleCompare; + } + if (d1 < (double)LONG_MIN) { + return MP_LT; + } + if (d1 > (double)LONG_MAX) { + return MP_GT; + } + l1 = (long) d1; + goto longCompare; +#ifndef NO_WIDE_TYPE + case TCL_NUMBER_WIDE: + w2 = *((const Tcl_WideInt *)ptr2); + d2 = (double) w2; + if (DBL_MANT_DIG > CHAR_BIT*sizeof(Tcl_WideInt) + || w2 == (Tcl_WideInt) d2 || modf(d1, &tmp) != 0.0) { + goto doubleCompare; + } + if (d1 < (double)LLONG_MIN) { + return MP_LT; + } + if (d1 > (double)LLONG_MAX) { + return MP_GT; + } + w1 = (Tcl_WideInt) d1; + goto wideCompare; +#endif + case TCL_NUMBER_BIG: + if (TclIsInfinite(d1)) { + return (d1 > 0.0) ? MP_GT : MP_LT; + } + Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2); + if ((d1 < (double)LONG_MAX) && (d1 > (double)LONG_MIN)) { + if (mp_cmp_d(&big2, 0) == MP_LT) { + compare = MP_GT; + } else { + compare = MP_LT; + } + mp_clear(&big2); + return compare; + } + if (DBL_MANT_DIG > CHAR_BIT*sizeof(long) + && modf(d1, &tmp) != 0.0) { + d2 = TclBignumToDouble(&big2); + mp_clear(&big2); + goto doubleCompare; + } + Tcl_InitBignumFromDouble(NULL, d1, &big1); + goto bigCompare; + } + + case TCL_NUMBER_BIG: + Tcl_TakeBignumFromObj(NULL, valuePtr, &big1); + switch (type2) { +#ifndef NO_WIDE_TYPE + case TCL_NUMBER_WIDE: +#endif + case TCL_NUMBER_LONG: + compare = mp_cmp_d(&big1, 0); + mp_clear(&big1); + return compare; + case TCL_NUMBER_DOUBLE: + d2 = *((const double *)ptr2); + if (TclIsInfinite(d2)) { + compare = (d2 > 0.0) ? MP_LT : MP_GT; + mp_clear(&big1); + return compare; + } + if ((d2 < (double)LONG_MAX) && (d2 > (double)LONG_MIN)) { + compare = mp_cmp_d(&big1, 0); + mp_clear(&big1); + return compare; + } + if (DBL_MANT_DIG > CHAR_BIT*sizeof(long) + && modf(d2, &tmp) != 0.0) { + d1 = TclBignumToDouble(&big1); + mp_clear(&big1); + goto doubleCompare; + } + Tcl_InitBignumFromDouble(NULL, d2, &big2); + goto bigCompare; + case TCL_NUMBER_BIG: + Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2); + bigCompare: + compare = mp_cmp(&big1, &big2); + mp_clear(&big1); + mp_clear(&big2); + return compare; + } + default: + Tcl_Panic("unexpected number type"); + return TCL_ERROR; + } +} #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)) \ |