diff options
Diffstat (limited to 'generic/tclExecute.c')
| -rw-r--r-- | generic/tclExecute.c | 406 |
1 files changed, 222 insertions, 184 deletions
diff --git a/generic/tclExecute.c b/generic/tclExecute.c index d77e51e..3f47527 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -12,7 +12,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.218 2005/10/22 01:35:26 msofer Exp $ + * RCS: @(#) $Id: tclExecute.c,v 1.219 2005/11/02 11:55:47 dkf Exp $ */ #include "tclInt.h" @@ -23,7 +23,7 @@ #include <float.h> /* - * Hack to determine whether we may expect IEEE floating point. The hack is + * Hack to determine whether we may expect IEEE floating point. The hack is * formally incorrect in that non-IEEE platforms might have the same precision * and range, but VAX, IBM, and Cray do not; are there any other floating * point units that we might care about? @@ -262,8 +262,8 @@ long tclObjsShared[TCL_MAX_SHARED_OBJ_STATS] = { 0, 0, 0, 0, 0 }; * * GET_WIDE_OR_INT is the same as REQUIRE_WIDE_OR_INT except it never * generates an error message. - * */ + #define REQUIRE_WIDE_OR_INT(resultVar, objPtr, longVar, wideVar) \ (resultVar) = Tcl_GetWideIntFromObj(interp, (objPtr), &(wideVar)); \ if ((resultVar) == TCL_OK && (wideVar) >= Tcl_LongAsWide(LONG_MIN) \ @@ -282,9 +282,11 @@ long tclObjsShared[TCL_MAX_SHARED_OBJ_STATS] = { 0, 0, 0, 0, 0 }; = Tcl_WideAsLong(wideVar); \ } #endif + /* * Combined with REQUIRE_WIDE_OR_INT, this gets a long value from an obj. */ + #if 0 #define W0 Tcl_LongAsWide(0) /* @@ -295,7 +297,7 @@ long tclObjsShared[TCL_MAX_SHARED_OBJ_STATS] = { 0, 0, 0, 0, 0 }; /* * Macro used in this file to save a function call for common uses of - * TclGetNumberFromObj(). The ANSI C "prototype" is: + * TclGetNumberFromObj(). The ANSI C "prototype" is: * * MODULE_SCOPE int GetNumberFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, * ClientData *ptrPtr, int *tPtr); @@ -390,41 +392,36 @@ static Tcl_ObjType dictIteratorType = { * Declarations for local procedures to this file: */ -static int TclExecuteByteCode _ANSI_ARGS_((Tcl_Interp *interp, - ByteCode *codePtr)); +static int TclExecuteByteCode(Tcl_Interp *interp, + ByteCode *codePtr); #ifdef TCL_COMPILE_STATS -static int EvalStatsCmd _ANSI_ARGS_((ClientData clientData, +static int EvalStatsCmd(ClientData clientData, Tcl_Interp *interp, int objc, - Tcl_Obj *CONST objv[])); + Tcl_Obj *CONST objv[]); #endif /* TCL_COMPILE_STATS */ #ifdef TCL_COMPILE_DEBUG -static char * GetOpcodeName _ANSI_ARGS_((unsigned char *pc)); +static char * GetOpcodeName(unsigned char *pc); #endif /* TCL_COMPILE_DEBUG */ -static ExceptionRange * GetExceptRangeForPc _ANSI_ARGS_((unsigned char *pc, - int catchOnly, ByteCode* codePtr)); -static char * GetSrcInfoForPc _ANSI_ARGS_((unsigned char *pc, - ByteCode* codePtr, int *lengthPtr)); -static void GrowEvaluationStack _ANSI_ARGS_((ExecEnv *eePtr)); -static void IllegalExprOperandType _ANSI_ARGS_(( - Tcl_Interp *interp, unsigned char *pc, - Tcl_Obj *opndPtr)); -static void InitByteCodeExecution _ANSI_ARGS_(( - Tcl_Interp *interp)); +static ExceptionRange * GetExceptRangeForPc(unsigned char *pc, + int catchOnly, ByteCode* codePtr); +static char * GetSrcInfoForPc(unsigned char *pc, + ByteCode* codePtr, int *lengthPtr); +static void GrowEvaluationStack(ExecEnv *eePtr); +static void IllegalExprOperandType(Tcl_Interp *interp, + unsigned char *pc, Tcl_Obj *opndPtr); +static void InitByteCodeExecution(Tcl_Interp *interp); #ifdef TCL_COMPILE_DEBUG -static void PrintByteCodeInfo _ANSI_ARGS_((ByteCode *codePtr)); -static char * StringForResultCode _ANSI_ARGS_((int result)); -static void ValidatePcAndStackTop _ANSI_ARGS_(( - ByteCode *codePtr, unsigned char *pc, - int stackTop, int stackLowerBound, - int checkStack)); +static void PrintByteCodeInfo(ByteCode *codePtr); +static char * StringForResultCode(int result); +static void ValidatePcAndStackTop(ByteCode *codePtr, + unsigned char *pc, int stackTop, + int stackLowerBound, int checkStack); #endif /* TCL_COMPILE_DEBUG */ #if 0 -static Tcl_WideInt ExponWide _ANSI_ARGS_((Tcl_WideInt w, Tcl_WideInt w2, - int *errExpon)); -static long ExponLong _ANSI_ARGS_((long i, long i2, - int *errExpon)); +static Tcl_WideInt ExponWide(Tcl_WideInt w, Tcl_WideInt w2, + int *errExpon); +static long ExponLong(long i, long i2, int *errExpon); #endif - /* *---------------------------------------------------------------------- @@ -448,8 +445,8 @@ static long ExponLong _ANSI_ARGS_((long i, long i2, */ static void -InitByteCodeExecution(interp) - Tcl_Interp *interp; /* Interpreter for which the Tcl variable +InitByteCodeExecution( + Tcl_Interp *interp) /* Interpreter for which the Tcl variable * "tcl_traceExec" is linked to control * instruction tracing. */ { @@ -490,8 +487,8 @@ InitByteCodeExecution(interp) #define TCL_STACK_INITIAL_SIZE 2000 ExecEnv * -TclCreateExecEnv(interp) - Tcl_Interp *interp; /* Interpreter for which the execution +TclCreateExecEnv( + Tcl_Interp *interp) /* Interpreter for which the execution * environment is being created. */ { ExecEnv *eePtr = (ExecEnv *) ckalloc(sizeof(ExecEnv)); @@ -547,8 +544,8 @@ TclCreateExecEnv(interp) */ void -TclDeleteExecEnv(eePtr) - ExecEnv *eePtr; /* Execution environment to free. */ +TclDeleteExecEnv( + ExecEnv *eePtr) /* Execution environment to free. */ { if (eePtr->stackPtr[-1] == (Tcl_Obj *) ((char *) 1)) { ckfree((char *) (eePtr->stackPtr-1)); @@ -579,7 +576,7 @@ TclDeleteExecEnv(eePtr) */ void -TclFinalizeExecution() +TclFinalizeExecution(void) { Tcl_MutexLock(&execMutex); execInitialized = 0; @@ -604,8 +601,8 @@ TclFinalizeExecution() */ static void -GrowEvaluationStack(eePtr) - register ExecEnv *eePtr; /* Points to the ExecEnv with an evaluation +GrowEvaluationStack( + register ExecEnv *eePtr) /* Points to the ExecEnv with an evaluation * stack to enlarge. */ { /* @@ -672,9 +669,9 @@ GrowEvaluationStack(eePtr) */ char * -TclStackAlloc(interp, numBytes) - Tcl_Interp *interp; - int numBytes; +TclStackAlloc( + Tcl_Interp *interp, + int numBytes) { Interp *iPtr = (Interp *) interp; ExecEnv *eePtr = iPtr->execEnvPtr; @@ -716,8 +713,8 @@ TclStackAlloc(interp, numBytes) } void -TclStackFree(interp) - Tcl_Interp *interp; +TclStackFree( + Tcl_Interp *interp) { Interp *iPtr = (Interp *) interp; ExecEnv *eePtr = iPtr->execEnvPtr; @@ -756,12 +753,12 @@ TclStackFree(interp) */ int -Tcl_ExprObj(interp, objPtr, resultPtrPtr) - Tcl_Interp *interp; /* Context in which to evaluate the +Tcl_ExprObj( + Tcl_Interp *interp, /* Context in which to evaluate the * expression. */ - register Tcl_Obj *objPtr; /* Points to Tcl object containing expression + register Tcl_Obj *objPtr, /* Points to Tcl object containing expression * to evaluate. */ - Tcl_Obj **resultPtrPtr; /* Where the Tcl_Obj* that is the expression + Tcl_Obj **resultPtrPtr) /* Where the Tcl_Obj* that is the expression * result is stored if no errors occur. */ { Interp *iPtr = (Interp *) interp; @@ -769,7 +766,7 @@ Tcl_ExprObj(interp, objPtr, resultPtrPtr) * in frame. */ LiteralTable *localTablePtr = &(compEnv.localLitTable); register ByteCode *codePtr = NULL; - /* Tcl Internal type of bytecode. Initialized + /* Tcl Internal type of bytecode. Initialized * to avoid compiler warning. */ AuxData *auxDataPtr; LiteralEntry *entryPtr; @@ -926,7 +923,7 @@ Tcl_ExprObj(interp, objPtr, resultPtrPtr) /* * If the expression evaluated successfully, store a pointer to its value - * object in resultPtrPtr then restore the old interpreter result. We + * object in resultPtrPtr then restore the old interpreter result. We * increment the object's ref count to reflect the reference that we are * returning to the caller. We also decrement the ref count of the * interpreter's result object after calling Tcl_SetResult since we next @@ -963,9 +960,9 @@ Tcl_ExprObj(interp, objPtr, resultPtrPtr) */ int -TclCompEvalObj(interp, objPtr) - Tcl_Interp *interp; - Tcl_Obj *objPtr; +TclCompEvalObj( + Tcl_Interp *interp, + Tcl_Obj *objPtr) { register Interp *iPtr = (Interp *) interp; register ByteCode* codePtr; /* Tcl Internal type of bytecode. */ @@ -991,7 +988,7 @@ TclCompEvalObj(interp, objPtr) /* * If the object is not already of tclByteCodeType, compile it (and reset * the compilation flags in the interpreter; this should be done after any - * compilation). Otherwise, check that it is "fresh" enough. + * compilation). Otherwise, check that it is "fresh" enough. */ if (objPtr->typePtr != &tclByteCodeType) { @@ -1007,19 +1004,20 @@ TclCompEvalObj(interp, objPtr) /* * Make sure the Bytecode hasn't been invalidated by, e.g., someone * redefining a command with a compile procedure (this might make the - * compiled code wrong). The object needs to be recompiled if it was + * compiled code wrong). The object needs to be recompiled if it was * compiled in/for a different interpreter, or for a different * namespace, or for the same namespace but with different name - * resolution rules. Precompiled objects, however, are immutable and + * resolution rules. Precompiled objects, however, are immutable and * therefore they are not recompiled, even if the epoch has changed. * * To be pedantically correct, we should also check that the * originating procPtr is the same as the current context procPtr - * (assuming one exists at all - none for global level). This code is + * (assuming one exists at all - none for global level). This code is * #def'ed out because [info body] was changed to never return a * bytecode type object, which should obviate us from the extra checks * here. */ + codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr; if (((Interp *) *codePtr->interpHandle != iPtr) || (codePtr->compileEpoch != iPtr->compileEpoch) @@ -1064,9 +1062,9 @@ TclCompEvalObj(interp, objPtr) * * TclIncrObj -- * - * Increment an integeral value in a Tcl_Obj by an integeral value - * held in another Tcl_Obj. Caller is responsible for making sure - * we can update the first object. + * Increment an integeral value in a Tcl_Obj by an integeral value held + * in another Tcl_Obj. Caller is responsible for making sure we can + * update the first object. * * Results: * TCL_ERROR if either object is non-integer, and TCL_OK otherwise. On @@ -1080,10 +1078,10 @@ TclCompEvalObj(interp, objPtr) */ int -TclIncrObj(interp, valuePtr, incrPtr) - Tcl_Interp *interp; - Tcl_Obj *valuePtr; - Tcl_Obj *incrPtr; +TclIncrObj( + Tcl_Interp *interp, + Tcl_Obj *valuePtr, + Tcl_Obj *incrPtr) { ClientData ptr1, ptr2; int type1, type2; @@ -1124,7 +1122,7 @@ TclIncrObj(interp, valuePtr, incrPtr) return TCL_OK; } #endif - } + } if ((type1 == TCL_NUMBER_DOUBLE) || (type1 == TCL_NUMBER_NAN)) { /* Produce error message (reparse?!) */ @@ -1151,7 +1149,7 @@ TclIncrObj(interp, valuePtr, incrPtr) } } #endif - + Tcl_GetBignumAndClearObj(interp, valuePtr, &value); Tcl_GetBignumFromObj(interp, incrPtr, &incr); mp_add(&value, &incr, &value); @@ -1180,9 +1178,9 @@ TclIncrObj(interp, valuePtr, incrPtr) */ static int -TclExecuteByteCode(interp, codePtr) - Tcl_Interp *interp; /* Token for command interpreter. */ - ByteCode *codePtr; /* The bytecode sequence to interpret. */ +TclExecuteByteCode( + Tcl_Interp *interp, /* Token for command interpreter. */ + ByteCode *codePtr) /* The bytecode sequence to interpret. */ { /* * Compiler cast directive - not a real variable. @@ -1247,7 +1245,7 @@ TclExecuteByteCode(interp, codePtr) * * Make sure the catch stack is large enough to hold the maximum number of * catch commands that could ever be executing at the same time (this will - * be no more than the exception range array's depth). Make sure the + * be no more than the exception range array's depth). Make sure the * execution stack is large enough to execute this ByteCode. */ @@ -1376,6 +1374,7 @@ TclExecuteByteCode(interp, codePtr) if ((instructionCount++ & ASYNC_CHECK_COUNT_MASK) == 0) { if (Tcl_AsyncReady()) { int localResult; + DECACHE_STACK_INFO(); localResult = Tcl_AsyncInvoke(interp, result); CACHE_STACK_INFO(); @@ -1386,6 +1385,7 @@ TclExecuteByteCode(interp, codePtr) } if (Tcl_LimitReady(interp)) { int localResult; + DECACHE_STACK_INFO(); localResult = Tcl_LimitCheck(interp); CACHE_STACK_INFO(); @@ -1598,9 +1598,9 @@ TclExecuteByteCode(interp, codePtr) /* * If the first object is shared, we need a new obj for the result; - * otherwise, we can reuse the first object. In any case, make sure - * it has enough room to accomodate all the concatenated bytes. Note - * that if it is unshared its bytes are already copied by + * otherwise, we can reuse the first object. In any case, make sure it + * has enough room to accomodate all the concatenated bytes. Note that + * if it is unshared its bytes are already copied by * Tcl_SetObjectLength, so that we set the loop parameters to avoid * copying them again: p points to the end of the already copied * bytes, currPtr to the second object. @@ -2293,6 +2293,7 @@ TclExecuteByteCode(interp, codePtr) * value *will* be set to what's requested, so that the stack top * remains pointing to the same Tcl_Obj. */ + valuePtr = varPtr->value.objPtr; objResultPtr = *tosPtr; if (valuePtr != objResultPtr) { @@ -2574,8 +2575,7 @@ TclExecuteByteCode(interp, codePtr) } else { DECACHE_STACK_INFO(); objResultPtr = TclPtrIncrObjVar(interp, varPtr, arrayPtr, - part1, part2, - incrPtr, TCL_LEAVE_ERR_MSG); + part1, part2, incrPtr, TCL_LEAVE_ERR_MSG); CACHE_STACK_INFO(); Tcl_DecrRefCount(incrPtr); if (objResultPtr == NULL) { @@ -3040,6 +3040,7 @@ TclExecuteByteCode(interp, codePtr) /* * Basic list containment operators. */ + int found, s1len, s2len, llen, i; Tcl_Obj *valuePtr, *value2Ptr, *o; char *s1, *s2; @@ -3113,6 +3114,7 @@ TclExecuteByteCode(interp, codePtr) * String (in)equality check * TODO: Consider merging into INST_STR_CMP */ + int iResult; Tcl_Obj *valuePtr, *value2Ptr; @@ -3124,6 +3126,7 @@ TclExecuteByteCode(interp, codePtr) * On the off-chance that the objects are the same, we don't * really have to think hard about equality. */ + iResult = (*pc == INST_STR_EQ); } else { char *s1, *s2; @@ -3136,6 +3139,7 @@ TclExecuteByteCode(interp, codePtr) * We only need to check (in)equality when we have equal * length strings. */ + if (*pc == INST_STR_NEQ) { iResult = (strcmp(s1, s2) != 0); } else { @@ -3174,6 +3178,7 @@ TclExecuteByteCode(interp, codePtr) /* * String compare */ + CONST char *s1, *s2; int s1len, s2len, iResult; Tcl_Obj *valuePtr, *value2Ptr; @@ -3186,11 +3191,13 @@ TclExecuteByteCode(interp, codePtr) * The comparison function should compare up to the minimum byte * length only. */ + if (valuePtr == value2Ptr) { /* * In the pure equality case, set lengths too for the checks below * (or we could goto beyond it). */ + iResult = s1len = s2len = 0; } else if ((valuePtr->typePtr == &tclByteArrayType) && (value2Ptr->typePtr == &tclByteArrayType)) { @@ -3202,8 +3209,8 @@ TclExecuteByteCode(interp, codePtr) && (value2Ptr->typePtr == &tclStringType))) { /* * Do a unicode-specific comparison if both of the args are of - * String type. If the char length == byte length, we can do a - * memcmp. In benchmark testing this proved the most efficient + * String type. If the char length == byte length, we can do a + * memcmp. In benchmark testing this proved the most efficient * check between the unicode and string comparison operations. */ @@ -3258,7 +3265,7 @@ TclExecuteByteCode(interp, codePtr) iResult = (iResult >= 0); break; } - } + } if (iResult < 0) { TclNewIntObj(objResultPtr, -1); TRACE(("%.20s %.20s => %d\n", O2S(valuePtr), O2S(value2Ptr), -1)); @@ -3331,11 +3338,13 @@ TclExecuteByteCode(interp, codePtr) Tcl_UniChar ch; ch = Tcl_GetUniChar(valuePtr, index); + /* * This could be: Tcl_NewUnicodeObj((CONST Tcl_UniChar *)&ch, * 1) but creating the object as a string seems to be faster * in practical use. */ + length = Tcl_UniCharToUtf(ch, buf); objResultPtr = Tcl_NewStringObj(buf, length); } @@ -3376,7 +3385,7 @@ TclExecuteByteCode(interp, codePtr) } /* - * Reuse value2Ptr object already on stack if possible. Adjustment is + * Reuse value2Ptr object already on stack if possible. Adjustment is * 2 due to the nocase byte * TODO: consider peephole opt. */ @@ -3444,27 +3453,29 @@ TclExecuteByteCode(interp, codePtr) 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 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. + * 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; @@ -3602,7 +3613,7 @@ TclExecuteByteCode(interp, codePtr) } if ((DBL_MANT_DIG > CHAR_BIT*sizeof(long)) && (modf(d1, &tmp) != 0.0)) { - d2 = TclBignumToDouble( &big2); + d2 = TclBignumToDouble(&big2); mp_clear(&big2); goto doubleCompare; } @@ -3639,7 +3650,7 @@ TclExecuteByteCode(interp, codePtr) } if ((DBL_MANT_DIG > CHAR_BIT*sizeof(long)) && (modf(d2, &tmp) != 0.0)) { - d1 = TclBignumToDouble( &big1); + d1 = TclBignumToDouble(&big1); mp_clear(&big1); goto doubleCompare; } @@ -3772,11 +3783,12 @@ TclExecuteByteCode(interp, codePtr) result = Tcl_GetIntFromObj(NULL, value2Ptr, &shift); if (result != TCL_OK) { /* - * Technically, we could hold the value (1 << (INT_MAX+1)) - * in an mp_int, but since we're using mp_mul_2d() to do the + * Technically, we could hold the value (1 << (INT_MAX+1)) in + * an mp_int, but since we're using mp_mul_2d() to do the * work, and it takes only an int argument, that's a good * place to draw the line. */ + Tcl_SetObjResult(interp, Tcl_NewStringObj( "integer value too large to represent", -1)); goto checkForCatch; @@ -3784,8 +3796,8 @@ TclExecuteByteCode(interp, codePtr) /* Handle shifts within the native long range */ TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); if ((type1 == TCL_NUMBER_LONG) && (shift < CHAR_BIT*sizeof(long)) - && (l = *((CONST long *)ptr1)) - && !(((l>0) ? l : ~l) + && (l = *((CONST long *)ptr1)) + && !(((l>0) ? l : ~l) & -(1<<(CHAR_BIT*sizeof(long)-1-shift)))) { TclNewLongObj(objResultPtr, (l<<shift)); TRACE(("%s\n", O2S(objResultPtr))); @@ -3797,8 +3809,9 @@ TclExecuteByteCode(interp, codePtr) if ((type1 != TCL_NUMBER_BIG) && (shift < CHAR_BIT*sizeof(Tcl_WideInt))) { Tcl_WideInt w; + TclGetWideIntFromObj(NULL, valuePtr, &w); - if (!(((w>0) ? w : ~w) + if (!(((w>0) ? w : ~w) & -(((Tcl_WideInt)1) <<(CHAR_BIT*sizeof(Tcl_WideInt)-1-shift)))) { objResultPtr = Tcl_NewWideIntObj(w<<shift); @@ -3809,8 +3822,8 @@ TclExecuteByteCode(interp, codePtr) /* if ((type1 == TCL_NUMBER_LONG) && (shift < CHAR_BIT*sizeof(long)) - && (l = *((CONST long *)ptr1)) - && !(((l>0) ? l : ~l) + && (l = *((CONST long *)ptr1)) + && !(((l>0) ? l : ~l) & -(1<<(CHAR_BIT*sizeof(long)-1-shift)))) { TclNewLongObj(objResultPtr, (l<<shift)); TRACE(("%s\n", O2S(objResultPtr))); @@ -3824,21 +3837,23 @@ TclExecuteByteCode(interp, codePtr) /* 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)) { + || (*((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. + * 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) > (long)0); break; #ifndef NO_WIDE_TYPE - case TCL_NUMBER_WIDE: + case TCL_NUMBER_WIDE: zero = (*((CONST Tcl_WideInt *)ptr1) > (Tcl_WideInt)0); break; #endif @@ -3926,7 +3941,7 @@ TclExecuteByteCode(interp, codePtr) TRACE(("%s\n", O2S(objResultPtr))); NEXT_INST_F(1, 2, 1); } - + case INST_BITOR: case INST_BITXOR: case INST_BITAND: { @@ -3973,10 +3988,10 @@ TclExecuteByteCode(interp, codePtr) } /* - * Count how many positive arguments we have. If only one of the - * arguments is negative, store it in 'Second'. + * 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; @@ -4004,7 +4019,7 @@ TclExecuteByteCode(interp, codePtr) mp_and(First, &bigResult, &bigResult); break; case 0: - /* Both arguments negative + /* Both arguments negative * a & b = ~ (~a | ~b) = -(-a-1|-b-1)-1 */ mp_neg(First, First); mp_sub_d(First, 1, First); @@ -4034,7 +4049,7 @@ TclExecuteByteCode(interp, codePtr) mp_sub_d(&bigResult, 1, &bigResult); break; case 0: - /* Both arguments negative + /* Both arguments negative * a | b = ~ (~a & ~b) = -(-a-1&-b-1)-1 */ mp_neg(First, First); mp_sub_d(First, 1, First); @@ -4064,7 +4079,7 @@ TclExecuteByteCode(interp, codePtr) mp_sub_d(&bigResult, 1, &bigResult); break; case 0: - /* Both arguments negative + /* Both arguments negative * a ^ b = (~a ^ ~b) = (-a-1^-b-1) */ mp_neg(First, First); mp_sub_d(First, 1, First); @@ -4075,7 +4090,7 @@ TclExecuteByteCode(interp, codePtr) } break; } - + mp_clear(&big1); mp_clear(&big2); TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); @@ -4109,7 +4124,7 @@ TclExecuteByteCode(interp, codePtr) /* Unused, here to silence compiler warning. */ wResult = 0; } - + TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); if (Tcl_IsShared(valuePtr)) { objResultPtr = Tcl_NewWideIntObj(wResult); @@ -4139,7 +4154,7 @@ TclExecuteByteCode(interp, codePtr) /* Unused, here to silence compiler warning. */ lResult = 0; } - + TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); if (Tcl_IsShared(valuePtr)) { TclNewLongObj(objResultPtr, lResult); @@ -4205,6 +4220,7 @@ TclExecuteByteCode(interp, codePtr) * not specified. Tcl guarantees that the remainder will have the * same sign as the divisor and a smaller absolute value. */ + if (value2Ptr->typePtr == &tclWideIntType && w2 == W0) { if (valuePtr->typePtr == &tclIntType) { TRACE(("%ld "LLD" => DIVIDE BY ZERO\n", i, w2)); @@ -4232,19 +4248,23 @@ TclExecuteByteCode(interp, codePtr) } else if (value2Ptr->typePtr == &tclIntType) { w2 = Tcl_LongAsWide(i2); } - if ( w == LLONG_MIN && w2 == -1 ) { - /* Integer overflow could happen with (LLONG_MIN % -1) - * even though it is not possible in the code below. */ + if (w == LLONG_MIN && w2 == -1) { + /* + * Integer overflow could happen with (LLONG_MIN % -1) + * even though it is not possible in the code below. + */ + wRemainder = 0; - } else if ( w == LLONG_MIN && w2 == LLONG_MAX ) { + } else if (w == LLONG_MIN && w2 == LLONG_MAX) { wRemainder = LLONG_MAX - 1; - } else if ( w2 == LLONG_MIN ) { + } else if (w2 == LLONG_MIN) { /* * In C, a modulus operation is not well defined when the * divisor is a negative number. So w % LLONG_MIN is not * well defined in the code below because -LLONG_MIN is * still a negative number. */ + if (w == 0 || w == LLONG_MIN) { wRemainder = 0; } else if (w < 0) { @@ -4268,6 +4288,7 @@ TclExecuteByteCode(interp, codePtr) * the divisor in that case because the remainder should * not be negative. */ + if (wRemainder < 0 && !(neg_divisor && (w == LLONG_MIN))) { wRemainder += w2; } @@ -4281,21 +4302,23 @@ TclExecuteByteCode(interp, codePtr) break; } - if ( i == LONG_MIN && i2 == -1 ) { + if (i == LONG_MIN && i2 == -1) { /* * Integer overflow could happen with (LONG_MIN % -1) even * though it is not possible in the code below. */ + rem = 0; - } else if ( i == LONG_MIN && i2 == LONG_MAX ) { + } else if (i == LONG_MIN && i2 == LONG_MAX) { rem = LONG_MAX - 1; - } else if ( i2 == LONG_MIN ) { + } else if (i2 == LONG_MIN) { /* * In C, a modulus operation is not well defined when the * divisor is a negative number. So i % LONG_MIN is not well * defined in the code below because -LONG_MIN is still a * negative number. */ + if (i == 0 || i == LONG_MIN) { rem = 0; } else if (i < 0) { @@ -4318,6 +4341,7 @@ TclExecuteByteCode(interp, codePtr) * dividend and a negative divisor. Don't add the divisor in * that case because the remainder should not be negative. */ + if (rem < 0 && !(neg_divisor && (i == LONG_MIN))) { rem += i2; } @@ -4366,14 +4390,14 @@ TclExecuteByteCode(interp, codePtr) Tcl_Obj *valuePtr = *(tosPtr - 1); result = GetNumberFromObj(NULL, valuePtr, &ptr1, &type1); - if ((result != TCL_OK) + if ((result != TCL_OK) #ifndef ACCEPT_NAN || (type1 == TCL_NUMBER_NAN) #endif ) { result = TCL_ERROR; TRACE(("%.20s %.20s => ILLEGAL 1st TYPE %s\n", - O2S(value2Ptr), O2S(valuePtr), + O2S(value2Ptr), O2S(valuePtr), (valuePtr->typePtr? valuePtr->typePtr->name: "null"))); IllegalExprOperandType(interp, pc, valuePtr); goto checkForCatch; @@ -4387,14 +4411,14 @@ TclExecuteByteCode(interp, codePtr) #endif result = GetNumberFromObj(NULL, value2Ptr, &ptr2, &type2); - if ((result != TCL_OK) + if ((result != TCL_OK) #ifndef ACCEPT_NAN || (type2 == TCL_NUMBER_NAN) #endif ) { result = TCL_ERROR; TRACE(("%.20s %.20s => ILLEGAL 2nd TYPE %s\n", - O2S(value2Ptr), O2S(valuePtr), + O2S(value2Ptr), O2S(valuePtr), (value2Ptr->typePtr? value2Ptr->typePtr->name: "null"))); IllegalExprOperandType(interp, pc, value2Ptr); goto checkForCatch; @@ -4437,6 +4461,7 @@ TclExecuteByteCode(interp, codePtr) * we're on an IEEE box. Otherwise, this statement might cause * demons to fly out our noses. */ + dResult = d1 / d2; break; default: @@ -4488,7 +4513,7 @@ TclExecuteByteCode(interp, codePtr) } } - if ((sizeof(Tcl_WideInt) >= 2*sizeof(long)) && (*pc == INST_MULT) + if ((sizeof(Tcl_WideInt) >= 2*sizeof(long)) && (*pc == INST_MULT) && (type1 == TCL_NUMBER_LONG) && (type2 == TCL_NUMBER_LONG)) { Tcl_WideInt w1, w2, wResult; TclGetWideIntFromObj(NULL, valuePtr, &w1); @@ -4505,9 +4530,9 @@ TclExecuteByteCode(interp, codePtr) Tcl_SetWideIntObj(valuePtr, wResult); TRACE(("%s\n", O2S(valuePtr))); NEXT_INST_F(1, 1, 0); - } + } - if ((*pc != INST_MULT) + if ((*pc != INST_MULT) && (type1 != TCL_NUMBER_BIG) && (type2 != TCL_NUMBER_BIG)) { Tcl_WideInt w1, w2, wResult; TclGetWideIntFromObj(NULL, valuePtr, &w1); @@ -4615,7 +4640,7 @@ TclExecuteByteCode(interp, codePtr) mp_init(&bigRemainder); mp_div(&big1, &big2, &bigResult, &bigRemainder); /* TODO: internals intrusion */ - if (!mp_iszero(&bigRemainder) + if (!mp_iszero(&bigRemainder) && (bigRemainder.sign != big2.sign)) { /* Convert to Tcl's integer division rules */ mp_sub_d(&bigResult, 1, &bigResult); @@ -4672,7 +4697,7 @@ TclExecuteByteCode(interp, codePtr) } else if ((t1Ptr == &tclDoubleType) && (valuePtr->bytes == NULL)) { /* * We can only use the internal rep directly if there is no string - * rep. Otherwise the string rep might actually look like an + * rep. Otherwise the string rep might actually look like an * integer, which is preferred. */ @@ -4930,7 +4955,7 @@ TclExecuteByteCode(interp, codePtr) } #endif TRACE(("%.20s %.20s => ILLEGAL 1st TYPE %s\n", - O2S(value2Ptr), O2S(valuePtr), + O2S(value2Ptr), O2S(valuePtr), (valuePtr->typePtr? valuePtr->typePtr->name: "null"))); IllegalExprOperandType(interp, pc, valuePtr); goto checkForCatch; @@ -4946,7 +4971,7 @@ TclExecuteByteCode(interp, codePtr) } #endif TRACE(("%.20s %.20s => ILLEGAL 2nd TYPE %s\n", - O2S(value2Ptr), O2S(valuePtr), + O2S(value2Ptr), O2S(valuePtr), (value2Ptr->typePtr? value2Ptr->typePtr->name: "null"))); IllegalExprOperandType(interp, pc, value2Ptr); goto checkForCatch; @@ -5001,6 +5026,7 @@ TclExecuteByteCode(interp, codePtr) /* Both values are some kind of integer */ /* TODO: optimize use of narrower native integers */ mp_int big1, big2, bigResult, bigRemainder; + Tcl_GetBignumFromObj(NULL, valuePtr, &big1); Tcl_GetBignumFromObj(NULL, value2Ptr, &big2); mp_init(&bigResult); @@ -5015,7 +5041,7 @@ TclExecuteByteCode(interp, codePtr) } mp_init(&bigRemainder); mp_div(&big1, &big2, &bigResult, &bigRemainder); - if (!mp_iszero(&bigRemainder) + if (!mp_iszero(&bigRemainder) && (bigRemainder.sign != big2.sign)) { /* Convert to Tcl's integer division rules */ mp_sub_d(&bigResult, 1, &bigResult); @@ -5187,6 +5213,7 @@ TclExecuteByteCode(interp, codePtr) switch (type) { case TCL_NUMBER_DOUBLE: { double d; + if (Tcl_IsShared(valuePtr)) { TclNewDoubleObj(objResultPtr, -(*((CONST double *)ptr))); NEXT_INST_F(1, 1, 1); @@ -5317,7 +5344,7 @@ TclExecuteByteCode(interp, codePtr) * to make sure that "expr {0001}" yields "1", not "0001". * We implement this by _discarding_ the string rep since we * know it will be regenerated, if needed later, by formatting - * the internal rep's value. + * the internal rep's value. */ if (valuePtr->bytes == NULL) { TRACE(("\"%.20s\" => numeric, same Tcl_Obj\n", O2S(valuePtr))); @@ -5477,6 +5504,7 @@ TclExecuteByteCode(interp, codePtr) valIndex = (iterNum * numVars); for (j = 0; j < numVars; j++) { int setEmptyStr = 0; + if (valIndex >= listLen) { setEmptyStr = 1; TclNewObj(valuePtr); @@ -5796,6 +5824,7 @@ TclExecuteByteCode(interp, codePtr) /* * More complex because list-append can fail. */ + if (valPtr == NULL) { valPtr = Tcl_NewListObj(1, tosPtr); } else if (Tcl_IsShared(valPtr)) { @@ -5931,10 +5960,12 @@ TclExecuteByteCode(interp, codePtr) Tcl_DictObjDone(searchPtr); ckfree((char *) searchPtr); } + /* - * Set the internal variable to an empty object to signify - * that we don't hold an iterator. + * Set the internal variable to an empty object to signify that we + * don't hold an iterator. */ + Tcl_DecrRefCount(statePtr); TclNewObj(emptyPtr); compiledLocals[opnd].value.objPtr = emptyPtr; @@ -6035,7 +6066,7 @@ TclExecuteByteCode(interp, codePtr) allocdict = Tcl_IsShared(dictPtr); if (allocdict) { dictPtr = Tcl_DuplicateObj(dictPtr); - } + } for (i=0 ; i<length ; i++) { Tcl_Obj *valPtr; int varIdx; @@ -6347,7 +6378,7 @@ TclExecuteByteCode(interp, codePtr) * * PrintByteCodeInfo -- * - * This procedure prints a summary about a bytecode object to stdout. It + * This procedure prints a summary about a bytecode object to stdout. It * is called by TclExecuteByteCode when starting to execute the bytecode * object if tclTraceExec has the value 2 or more. * @@ -6361,8 +6392,8 @@ TclExecuteByteCode(interp, codePtr) */ static void -PrintByteCodeInfo(codePtr) - register ByteCode *codePtr; /* The bytecode whose summary is printed to +PrintByteCodeInfo( + register ByteCode *codePtr) /* The bytecode whose summary is printed to * stdout. */ { Proc *procPtr = codePtr->procPtr; @@ -6426,16 +6457,16 @@ PrintByteCodeInfo(codePtr) #ifdef TCL_COMPILE_DEBUG static void -ValidatePcAndStackTop(codePtr, pc, stackTop, stackLowerBound, checkStack) - register ByteCode *codePtr; /* The bytecode whose summary is printed to +ValidatePcAndStackTop( + register ByteCode *codePtr, /* The bytecode whose summary is printed to * stdout. */ - unsigned char *pc; /* Points to first byte of a bytecode + unsigned char *pc, /* Points to first byte of a bytecode * instruction. The program counter. */ - int stackTop; /* Current stack top. Must be between + int stackTop, /* Current stack top. Must be between * stackLowerBound and stackUpperBound * (inclusive). */ - int stackLowerBound; /* Smallest legal value for stackTop. */ - int checkStack; /* 0 if the stack depth check should be + int stackLowerBound, /* Smallest legal value for stackTop. */ + int checkStack) /* 0 if the stack depth check should be * skipped. */ { int stackUpperBound = stackLowerBound + codePtr->maxStackDepth; @@ -6496,12 +6527,12 @@ ValidatePcAndStackTop(codePtr, pc, stackTop, stackLowerBound, checkStack) */ static void -IllegalExprOperandType(interp, pc, opndPtr) - Tcl_Interp *interp; /* Interpreter to which error information +IllegalExprOperandType( + Tcl_Interp *interp, /* Interpreter to which error information * pertains. */ - unsigned char *pc; /* Points to the instruction being executed + unsigned char *pc, /* Points to the instruction being executed * when the illegal type was found. */ - Tcl_Obj *opndPtr; /* Points to the operand holding the value + Tcl_Obj *opndPtr) /* Points to the operand holding the value * with the illegal type. */ { ClientData ptr; @@ -6563,14 +6594,14 @@ IllegalExprOperandType(interp, pc, opndPtr) */ static char * -GetSrcInfoForPc(pc, codePtr, lengthPtr) - unsigned char *pc; /* The program counter value for which to +GetSrcInfoForPc( + unsigned char *pc, /* The program counter value for which to * return the closest command's source info. * This points to a bytecode instruction in * codePtr's code. */ - ByteCode *codePtr; /* The bytecode sequence in which to look up + ByteCode *codePtr, /* The bytecode sequence in which to look up * the command source for the pc. */ - int *lengthPtr; /* If non-NULL, the location where the length + int *lengthPtr) /* If non-NULL, the location where the length * of the command's source should be stored. * If NULL, no length is stored. */ { @@ -6685,16 +6716,16 @@ GetSrcInfoForPc(pc, codePtr, lengthPtr) */ static ExceptionRange * -GetExceptRangeForPc(pc, catchOnly, codePtr) - unsigned char *pc; /* The program counter value for which to +GetExceptRangeForPc( + unsigned char *pc, /* The program counter value for which to * search for a closest enclosing exception * range. This points to a bytecode * instruction in codePtr's code. */ - int catchOnly; /* If 0, consider either loop or catch + int catchOnly, /* If 0, consider either loop or catch * ExceptionRanges in search. If nonzero * consider only catch ranges (and ignore any * closer loop ranges). */ - ByteCode* codePtr; /* Points to the ByteCode in which to search + ByteCode* codePtr) /* Points to the ByteCode in which to search * for the enclosing ExceptionRange. */ { ExceptionRange *rangeArrayPtr; @@ -6748,8 +6779,8 @@ GetExceptRangeForPc(pc, catchOnly, codePtr) #ifdef TCL_COMPILE_DEBUG static char * -GetOpcodeName(pc) - unsigned char *pc; /* Points to the instruction whose name should +GetOpcodeName( + unsigned char *pc) /* Points to the instruction whose name should * be returned. */ { unsigned char opCode = *pc; @@ -6758,7 +6789,6 @@ GetOpcodeName(pc) } #endif /* TCL_COMPILE_DEBUG */ - /* *---------------------------------------------------------------------- * @@ -6777,9 +6807,9 @@ GetOpcodeName(pc) */ void -TclExprFloatError(interp, value) - Tcl_Interp *interp; /* Where to store error message. */ - double value; /* Value returned after error; used to +TclExprFloatError( + Tcl_Interp *interp, /* Where to store error message. */ + double value) /* Value returned after error; used to * distinguish underflows from overflows. */ { CONST char *s; @@ -6802,7 +6832,7 @@ TclExprFloatError(interp, value) Tcl_Obj *objPtr = Tcl_NewObj(); TclObjPrintf(NULL, objPtr, "unknown floating-point error, errno = %d", errno); - Tcl_SetErrorCode(interp, "ARITH", "UNKNOWN", + Tcl_SetErrorCode(interp, "ARITH", "UNKNOWN", Tcl_GetString(objPtr), (char *) NULL); Tcl_SetObjResult(interp, objPtr); } @@ -6828,8 +6858,8 @@ TclExprFloatError(interp, value) */ int -TclLog2(value) - register int value; /* The integer for which to compute the log +TclLog2( + register int value) /* The integer for which to compute the log * base 2. */ { register int n = value; @@ -6860,11 +6890,11 @@ TclLog2(value) */ static int -EvalStatsCmd(unused, interp, objc, objv) - ClientData unused; /* Unused. */ - Tcl_Interp *interp; /* The current interpreter. */ - int objc; /* The number of arguments. */ - Tcl_Obj *CONST objv[]; /* The argument strings. */ +EvalStatsCmd( + ClientData unused, /* Unused. */ + Tcl_Interp *interp, /* The current interpreter. */ + int objc, /* The number of arguments. */ + Tcl_Obj *CONST objv[]) /* The argument strings. */ { Interp *iPtr = (Interp *) interp; LiteralTable *globalTablePtr = &(iPtr->literalTable); @@ -7263,8 +7293,8 @@ EvalStatsCmd(unused, interp, objc, objv) */ static char * -StringForResultCode(result) - int result; /* The Tcl result code for which to generate a +StringForResultCode( + int result) /* The Tcl result code for which to generate a * string. */ { static char buf[TCL_INTEGER_SPACE]; @@ -7296,10 +7326,10 @@ StringForResultCode(result) */ static Tcl_WideInt -ExponWide(w, w2, errExpon) - Tcl_WideInt w; /* The value that must be exponentiated */ - Tcl_WideInt w2; /* The exponent */ - int *errExpon; /* Error code */ +ExponWide( + Tcl_WideInt w, /* The value that must be exponentiated */ + Tcl_WideInt w2, /* The exponent */ + int *errExpon) /* Error code */ { Tcl_WideInt result; @@ -7362,10 +7392,10 @@ ExponWide(w, w2, errExpon) */ static long -ExponLong(i, i2, errExpon) - long i; /* The value that must be exponentiated */ - long i2; /* The exponent */ - int *errExpon; /* Error code */ +ExponLong( + long i, /* The value that must be exponentiated */ + long i2, /* The exponent */ + int *errExpon) /* Error code */ { long result; @@ -7413,3 +7443,11 @@ ExponLong(i, i2, errExpon) return result * i; } #endif + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ |