diff options
| -rw-r--r-- | generic/tclCompile.c | 141 | ||||
| -rw-r--r-- | generic/tclExecute.c | 388 | ||||
| -rw-r--r-- | generic/tclGet.c | 4 | ||||
| -rw-r--r-- | generic/tclInt.h | 4 | ||||
| -rw-r--r-- | generic/tclObj.c | 3 | ||||
| -rw-r--r-- | generic/tclParseExpr.c | 24 | ||||
| -rw-r--r-- | generic/tclUtil.c | 56 |
7 files changed, 257 insertions, 363 deletions
diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 7df3815..cc7462b 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -10,7 +10,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclCompile.c,v 1.17 1999/10/21 02:16:22 hobbs Exp $ + * RCS: @(#) $Id: tclCompile.c,v 1.18 1999/12/04 06:15:40 hobbs Exp $ */ #include "tclInt.h" @@ -882,6 +882,13 @@ TclCompileScript(interp, script, numBytes, nested, envPtr) } else if (code == TCL_OUT_LINE_COMPILE) { /* do nothing */ } else { /* an error */ + /* + * There was a compilation error, the last + * command did not get compiled into (*envPtr). + * Decrement the number of commands + * claimed to be in (*envPtr). + */ + envPtr->numCommands--; goto error; } } @@ -1344,9 +1351,8 @@ TclCompileExprWords(interp, tokenPtr, numWords, envPtr) * token contains one or more subtokens. */ CompileEnv *envPtr; /* Holds the resulting instructions. */ { - Tcl_Token *wordPtr, *partPtr; - JumpFixup jumpFixup; - int maxDepth, doExprInline, range, numBytes, i, j, code; + Tcl_Token *wordPtr; + int maxDepth, range, numBytes, i, code; char *script; int saveExprIsJustVarRef = envPtr->exprIsJustVarRef; int saveExprIsComparison = envPtr->exprIsComparison; @@ -1372,112 +1378,7 @@ TclCompileExprWords(interp, tokenPtr, numWords, envPtr) code = TclCompileExpr(interp, script, numBytes, envPtr); return code; } - - /* - * Multiple words or the single word requires substitutions. We may - * need to call expr's command proc at runtime. This often recompiles - * the expression each time and is slow. However, there are some - * circumstances where we can still compile inline code "optimistically" - * and check for type errors during execution that signal when double - * substitutions must be done. - */ - - doExprInline = 1; - wordPtr = tokenPtr; - for (i = 0; ((i < numWords) && doExprInline); i++) { - if (wordPtr->type == TCL_TOKEN_WORD) { - for (j = 0, partPtr = wordPtr+1; j < wordPtr->numComponents; - j++, partPtr++) { - if ((partPtr->type == TCL_TOKEN_BS) - || (partPtr->type == TCL_TOKEN_COMMAND) - || (partPtr->type == TCL_TOKEN_VARIABLE)) { - doExprInline = 0; - break; - } - } - } - wordPtr += (wordPtr->numComponents + 1); - } - - /* - * If only variable substitutions appear (no backslash or command - * substitutions), inline compile the expr inside a "catch" so that if - * there is any error, we call expr's command proc at runtime. - */ - - if (doExprInline) { - Tcl_DString exprBuffer; - int startCodeOffset = (envPtr->codeNext - envPtr->codeStart); - int startExceptNext = envPtr->exceptArrayNext; - - envPtr->exceptDepth++; - envPtr->maxExceptDepth = - TclMax(envPtr->exceptDepth, envPtr->maxExceptDepth); - range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr); - TclEmitInstInt4(INST_BEGIN_CATCH4, range, envPtr); - - Tcl_DStringInit(&exprBuffer); - wordPtr = tokenPtr; - for (i = 0; i < numWords; i++) { - if (i > 0) { - Tcl_DStringAppend(&exprBuffer, " ", 1); - } - for (j = 0, partPtr = wordPtr+1; j < wordPtr->numComponents; - j++, partPtr++) { - switch (partPtr->type) { - case TCL_TOKEN_TEXT: - Tcl_DStringAppend(&exprBuffer, partPtr->start, - partPtr->size); - break; - - case TCL_TOKEN_VARIABLE: - Tcl_DStringAppend(&exprBuffer, partPtr->start, - partPtr->size); - j += partPtr->numComponents; - partPtr += partPtr->numComponents; - break; - - default: - panic("unexpected token type in TclCompileExprWords"); - } - } - wordPtr += (wordPtr->numComponents + 1); - } - envPtr->exceptArrayPtr[range].codeOffset = - (envPtr->codeNext - envPtr->codeStart); - code = TclCompileExpr(interp, Tcl_DStringValue(&exprBuffer), - Tcl_DStringLength(&exprBuffer), envPtr); - envPtr->exceptArrayPtr[range].numCodeBytes = - (envPtr->codeNext - envPtr->codeStart) - - envPtr->exceptArrayPtr[range].codeOffset; - maxDepth = envPtr->maxStackDepth; - Tcl_DStringFree(&exprBuffer); - - if ((code != TCL_OK) || (envPtr->exprIsJustVarRef) - || (envPtr->exprIsComparison)) { - /* - * Delete the inline code and call the expr command proc at - * runtime. There was a compilation error or the inline code - * might not have the right 2 level substitution semantics: - * e.g., if the expr consisted of a single variable ref or the - * top-level operator is a comparison (which might operate on - * strings). The code might appear to execute successfully but - * produce the wrong result. We depend on execution failing if a - * second level of substitutions is required. - */ - - envPtr->codeNext = (envPtr->codeStart + startCodeOffset); - envPtr->exceptArrayNext = startExceptNext; - doExprInline = 0; - } else { - TclEmitOpcode(INST_END_CATCH, envPtr); /* for ok case */ - TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpFixup); - envPtr->exceptArrayPtr[range].catchOffset = - (envPtr->codeNext - envPtr->codeStart); - TclEmitOpcode(INST_END_CATCH, envPtr); /* for error case */ - } - } - + /* * Emit code to call the expr command proc at runtime. Concatenate the * (already substituted once) expr tokens with a space between each. @@ -1510,25 +1411,7 @@ TclCompileExprWords(interp, tokenPtr, numWords, envPtr) } TclEmitOpcode(INST_EXPR_STK, envPtr); } - - /* - * If generating inline code, update the target of the jump at the end. - */ - - if (doExprInline) { - int jumpDist = (envPtr->codeNext - envPtr->codeStart) - - jumpFixup.codeOffset; - if (TclFixupForwardJump(envPtr, &jumpFixup, jumpDist, 127)) { - /* - * Update the inline expression code's catch ExceptionRange - * target since it, being after the jump, also moved down. - */ - - envPtr->exceptArrayPtr[range].catchOffset += 3; - } - envPtr->exceptDepth--; - } - + envPtr->exprIsJustVarRef = saveExprIsJustVarRef; envPtr->exprIsComparison = saveExprIsComparison; envPtr->maxStackDepth = maxDepth; diff --git a/generic/tclExecute.c b/generic/tclExecute.c index c7e05a4..5262f6b 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -9,7 +9,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.7 1999/06/16 21:56:33 stanton Exp $ + * RCS: @(#) $Id: tclExecute.c,v 1.8 1999/12/04 06:15:41 hobbs Exp $ */ #include "tclInt.h" @@ -260,6 +260,8 @@ static void ValidatePcAndStackTop _ANSI_ARGS_(( int stackTop, int stackLowerBound, int stackUpperBound)); #endif +static int VerifyExprObjType _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Obj *objPtr)); /* * Table describing the built-in math functions. Entries in this table are @@ -3054,7 +3056,6 @@ IllegalExprOperandType(interp, pc, opndPtr) * with the illegal type. */ { unsigned char opCode = *pc; - int isDouble; Tcl_ResetResult(interp); if ((opndPtr->bytes == NULL) || (opndPtr->length == 0)) { @@ -3062,7 +3063,7 @@ IllegalExprOperandType(interp, pc, opndPtr) "can't use empty string as operand of \"", operatorStrings[opCode - INST_LOR], "\"", (char *) NULL); } else { - isDouble = 1; + char *msg = "non-numeric string"; if (opndPtr->typePtr != &tclDoubleType) { /* * See if the operand can be interpreted as a double in order to @@ -3072,13 +3073,20 @@ IllegalExprOperandType(interp, pc, opndPtr) char *s = Tcl_GetString(opndPtr); double d; - if (Tcl_GetDouble((Tcl_Interp *) NULL, s, &d) != TCL_OK) { - isDouble = 0; + if (Tcl_GetDouble((Tcl_Interp *) NULL, s, &d) == TCL_OK) { + /* + * Make sure that what appears to be a double + * (ie 08) isn't really a bad octal + */ + if (TclCheckBadOctal(NULL, Tcl_GetString(opndPtr))) { + msg = "invalid octal number"; + } else { + msg = "floating-point value"; + } } } Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "can't use ", - (isDouble? "floating-point value" : "non-numeric string"), - " as operand of \"", operatorStrings[opCode - INST_LOR], + msg, " as operand of \"", operatorStrings[opCode - INST_LOR], "\"", (char *) NULL); } } @@ -3373,6 +3381,61 @@ GetOpcodeName(pc) /* *---------------------------------------------------------------------- * + * VerifyExprObjType -- + * + * This procedure is called by the math functions to verify that + * the object is either an int or double, coercing it if necessary. + * If an error occurs during conversion, an error message is left + * in the interpreter's result unless "interp" is NULL. + * + * Results: + * TCL_OK if it was int or double, TCL_ERROR otherwise + * + * Side effects: + * objPtr is ensured to be either tclIntType of tclDoubleType. + * + *---------------------------------------------------------------------- + */ + +static int +VerifyExprObjType(interp, objPtr) + Tcl_Interp *interp; /* The interpreter in which to execute the + * function. */ + Tcl_Obj *objPtr; /* Points to the object to type check. */ +{ + if ((objPtr->typePtr == &tclIntType) || + (objPtr->typePtr == &tclDoubleType)) { + return TCL_OK; + } else { + int length, result = TCL_OK; + char *s = Tcl_GetStringFromObj(objPtr, &length); + + if (TclLooksLikeInt(s, length)) { + long i; + result = Tcl_GetLongFromObj((Tcl_Interp *) NULL, objPtr, &i); + } else { + double d; + result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL, objPtr, &d); + } + if ((result != TCL_OK) && (interp != NULL)) { + Tcl_ResetResult(interp); + if (TclCheckBadOctal((Tcl_Interp *) NULL, s)) { + Tcl_AppendToObj(Tcl_GetObjResult(interp), + "argument to math function was an invalid octal number", + -1); + } else { + Tcl_AppendToObj(Tcl_GetObjResult(interp), + "argument to math function didn't have numeric value", + -1); + } + } + return result; + } +} + +/* + *---------------------------------------------------------------------- + * * Math Functions -- * * This page contains the procedures that implement all of the @@ -3402,10 +3465,8 @@ ExprUnaryFunc(interp, eePtr, clientData) Tcl_Obj **stackPtr; /* Cached evaluation stack base pointer. */ register int stackTop; /* Cached top index of evaluation stack. */ register Tcl_Obj *valuePtr; - Tcl_ObjType *tPtr; double d, dResult; - long i; - int length, result; + int result; double (*func) _ANSI_ARGS_((double)) = (double (*)_ANSI_ARGS_((double))) clientData; @@ -3423,27 +3484,16 @@ ExprUnaryFunc(interp, eePtr, clientData) */ valuePtr = POP_OBJECT(); - tPtr = valuePtr->typePtr; + + if (VerifyExprObjType(interp, valuePtr) != TCL_OK) { + result = TCL_ERROR; + goto done; + } - if (tPtr == &tclIntType) { + if (valuePtr->typePtr == &tclIntType) { d = (double) valuePtr->internalRep.longValue; - } else if (tPtr == &tclDoubleType) { - d = valuePtr->internalRep.doubleValue; } else { - char *s = Tcl_GetStringFromObj(valuePtr, &length); - - if (TclLooksLikeInt(s, length)) { - result = Tcl_GetLongFromObj((Tcl_Interp *) NULL, valuePtr, &i); - d = (double) valuePtr->internalRep.longValue; - } else { - result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL, valuePtr, &d); - } - if (result != TCL_OK) { - Tcl_ResetResult(interp); - Tcl_AppendToObj(Tcl_GetObjResult(interp), - "argument to math function didn't have numeric value", -1); - goto done; - } + d = valuePtr->internalRep.doubleValue; } errno = 0; @@ -3483,11 +3533,8 @@ ExprBinaryFunc(interp, eePtr, clientData) Tcl_Obj **stackPtr; /* Cached evaluation stack base pointer. */ register int stackTop; /* Cached top index of evaluation stack. */ register Tcl_Obj *valuePtr, *value2Ptr; - Tcl_ObjType *tPtr; double d1, d2, dResult; - long i; - char *s; - int length, result; + int result; double (*func) _ANSI_ARGS_((double, double)) = (double (*)_ANSI_ARGS_((double, double))) clientData; @@ -3507,44 +3554,22 @@ ExprBinaryFunc(interp, eePtr, clientData) value2Ptr = POP_OBJECT(); valuePtr = POP_OBJECT(); - tPtr = valuePtr->typePtr; - if (tPtr == &tclIntType) { + if ((VerifyExprObjType(interp, valuePtr) != TCL_OK) || + (VerifyExprObjType(interp, value2Ptr) != TCL_OK)) { + result = TCL_ERROR; + goto done; + } + + if (valuePtr->typePtr == &tclIntType) { d1 = (double) valuePtr->internalRep.longValue; - } else if (tPtr == &tclDoubleType) { - d1 = valuePtr->internalRep.doubleValue; } else { - s = Tcl_GetStringFromObj(valuePtr, &length); - if (TclLooksLikeInt(s, length)) { - result = Tcl_GetLongFromObj((Tcl_Interp *) NULL, valuePtr, &i); - d1 = (double) valuePtr->internalRep.longValue; - } else { - result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL, valuePtr, &d1); - } - if (result != TCL_OK) { - badArg: - Tcl_ResetResult(interp); - Tcl_AppendToObj(Tcl_GetObjResult(interp), - "argument to math function didn't have numeric value", -1); - goto done; - } + d1 = valuePtr->internalRep.doubleValue; } - tPtr = value2Ptr->typePtr; - if (tPtr == &tclIntType) { - d2 = value2Ptr->internalRep.longValue; - } else if (tPtr == &tclDoubleType) { - d2 = value2Ptr->internalRep.doubleValue; + if (value2Ptr->typePtr == &tclIntType) { + d2 = (double) value2Ptr->internalRep.longValue; } else { - s = Tcl_GetStringFromObj(value2Ptr, &length); - if (TclLooksLikeInt(s, length)) { - result = Tcl_GetLongFromObj((Tcl_Interp *) NULL, value2Ptr, &i); - d2 = (double) value2Ptr->internalRep.longValue; - } else { - result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL, value2Ptr, &d2); - } - if (result != TCL_OK) { - goto badArg; - } + d2 = value2Ptr->internalRep.doubleValue; } errno = 0; @@ -3583,10 +3608,9 @@ ExprAbsFunc(interp, eePtr, clientData) Tcl_Obj **stackPtr; /* Cached evaluation stack base pointer. */ register int stackTop; /* Cached top index of evaluation stack. */ register Tcl_Obj *valuePtr; - Tcl_ObjType *tPtr; long i, iResult; double d, dResult; - int length, result; + int result; /* * Set stackPtr and stackTop from eePtr. @@ -3600,34 +3624,17 @@ ExprAbsFunc(interp, eePtr, clientData) */ valuePtr = POP_OBJECT(); - tPtr = valuePtr->typePtr; - - if (tPtr == &tclIntType) { - i = valuePtr->internalRep.longValue; - } else if (tPtr == &tclDoubleType) { - d = valuePtr->internalRep.doubleValue; - } else { - char *s = Tcl_GetStringFromObj(valuePtr, &length); - - if (TclLooksLikeInt(s, length)) { - result = Tcl_GetLongFromObj((Tcl_Interp *) NULL, valuePtr, &i); - } else { - result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL, valuePtr, &d); - } - if (result != TCL_OK) { - Tcl_ResetResult(interp); - Tcl_AppendToObj(Tcl_GetObjResult(interp), - "argument to math function didn't have numeric value", -1); - goto done; - } - tPtr = valuePtr->typePtr; + + if (VerifyExprObjType(interp, valuePtr) != TCL_OK) { + result = TCL_ERROR; + goto done; } /* * Push a Tcl object with the result. */ - - if (tPtr == &tclIntType) { + if (valuePtr->typePtr == &tclIntType) { + i = valuePtr->internalRep.longValue; if (i < 0) { iResult = -i; if (iResult < 0) { @@ -3644,6 +3651,7 @@ ExprAbsFunc(interp, eePtr, clientData) } PUSH_OBJECT(Tcl_NewLongObj(iResult)); } else { + d = valuePtr->internalRep.doubleValue; if (d < 0.0) { dResult = -d; } else { @@ -3656,7 +3664,7 @@ ExprAbsFunc(interp, eePtr, clientData) } PUSH_OBJECT(Tcl_NewDoubleObj(dResult)); } - + /* * Reflect the change to stackTop back in eePtr. */ @@ -3679,8 +3687,7 @@ ExprDoubleFunc(interp, eePtr, clientData) register int stackTop; /* Cached top index of evaluation stack. */ register Tcl_Obj *valuePtr; double dResult; - long i; - int length, result; + int result; /* * Set stackPtr and stackTop from eePtr. @@ -3694,26 +3701,16 @@ ExprDoubleFunc(interp, eePtr, clientData) */ valuePtr = POP_OBJECT(); + + if (VerifyExprObjType(interp, valuePtr) != TCL_OK) { + result = TCL_ERROR; + goto done; + } + if (valuePtr->typePtr == &tclIntType) { dResult = (double) valuePtr->internalRep.longValue; - } else if (valuePtr->typePtr == &tclDoubleType) { - dResult = valuePtr->internalRep.doubleValue; } else { - char *s = Tcl_GetStringFromObj(valuePtr, &length); - - if (TclLooksLikeInt(s, length)) { - result = Tcl_GetLongFromObj((Tcl_Interp *) NULL, valuePtr, &i); - dResult = (double) valuePtr->internalRep.longValue; - } else { - result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL, valuePtr, - &dResult); - } - if (result != TCL_OK) { - Tcl_ResetResult(interp); - Tcl_AppendToObj(Tcl_GetObjResult(interp), - "argument to math function didn't have numeric value", -1); - goto done; - } + dResult = valuePtr->internalRep.doubleValue; } /* @@ -3743,11 +3740,9 @@ ExprIntFunc(interp, eePtr, clientData) Tcl_Obj **stackPtr; /* Cached evaluation stack base pointer. */ register int stackTop; /* Cached top index of evaluation stack. */ register Tcl_Obj *valuePtr; - Tcl_ObjType *tPtr; - long i = 0; /* Initialized to avoid compiler warning. */ long iResult; double d; - int length, result; + int result; /* * Set stackPtr and stackTop from eePtr. @@ -3761,36 +3756,16 @@ ExprIntFunc(interp, eePtr, clientData) */ valuePtr = POP_OBJECT(); - tPtr = valuePtr->typePtr; - if (tPtr == &tclIntType) { - i = valuePtr->internalRep.longValue; - } else if (tPtr == &tclDoubleType) { - d = valuePtr->internalRep.doubleValue; - } else { - char *s = Tcl_GetStringFromObj(valuePtr, &length); - - if (TclLooksLikeInt(s, length)) { - result = Tcl_GetLongFromObj((Tcl_Interp *) NULL, valuePtr, &i); - } else { - result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL, valuePtr, &d); - } - if (result != TCL_OK) { - Tcl_ResetResult(interp); - Tcl_AppendToObj(Tcl_GetObjResult(interp), - "argument to math function didn't have numeric value", -1); - goto done; - } - tPtr = valuePtr->typePtr; + if (VerifyExprObjType(interp, valuePtr) != TCL_OK) { + result = TCL_ERROR; + goto done; } - - /* - * Push a Tcl object with the result. - */ - if (tPtr == &tclIntType) { - iResult = i; + if (valuePtr->typePtr == &tclIntType) { + iResult = valuePtr->internalRep.longValue; } else { + d = valuePtr->internalRep.doubleValue; if (d < 0.0) { if (d < (double) (long) LONG_MIN) { tooLarge: @@ -3814,6 +3789,11 @@ ExprIntFunc(interp, eePtr, clientData) } iResult = (long) d; } + + /* + * Push a Tcl object with the result. + */ + PUSH_OBJECT(Tcl_NewLongObj(iResult)); /* @@ -3925,11 +3905,9 @@ ExprRoundFunc(interp, eePtr, clientData) Tcl_Obj **stackPtr; /* Cached evaluation stack base pointer. */ register int stackTop; /* Cached top index of evaluation stack. */ Tcl_Obj *valuePtr; - Tcl_ObjType *tPtr; - long i = 0; /* Initialized to avoid compiler warning. */ long iResult; double d, temp; - int length, result; + int result; /* * Set stackPtr and stackTop from eePtr. @@ -3943,36 +3921,16 @@ ExprRoundFunc(interp, eePtr, clientData) */ valuePtr = POP_OBJECT(); - tPtr = valuePtr->typePtr; - - if (tPtr == &tclIntType) { - i = valuePtr->internalRep.longValue; - } else if (tPtr == &tclDoubleType) { - d = valuePtr->internalRep.doubleValue; - } else { - char *s = Tcl_GetStringFromObj(valuePtr, &length); - - if (TclLooksLikeInt(s, length)) { - result = Tcl_GetLongFromObj((Tcl_Interp *) NULL, valuePtr, &i); - } else { - result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL, valuePtr, &d); - } - if (result != TCL_OK) { - Tcl_ResetResult(interp); - Tcl_AppendToObj(Tcl_GetObjResult(interp), - "argument to math function didn't have numeric value", -1); - goto done; - } - tPtr = valuePtr->typePtr; - } - /* - * Push a Tcl object with the result. - */ + if (VerifyExprObjType(interp, valuePtr) != TCL_OK) { + result = TCL_ERROR; + goto done; + } - if (tPtr == &tclIntType) { - iResult = i; + if (valuePtr->typePtr == &tclIntType) { + iResult = valuePtr->internalRep.longValue; } else { + d = valuePtr->internalRep.doubleValue; if (d < 0.0) { if (d <= (((double) (long) LONG_MIN) - 0.5)) { tooLarge: @@ -3999,6 +3957,11 @@ ExprRoundFunc(interp, eePtr, clientData) } iResult = (long) temp; } + + /* + * Push a Tcl object with the result. + */ + PUSH_OBJECT(Tcl_NewLongObj(iResult)); /* @@ -4023,9 +3986,8 @@ ExprSrandFunc(interp, eePtr, clientData) register int stackTop; /* Cached top index of evaluation stack. */ Interp *iPtr = (Interp *) interp; Tcl_Obj *valuePtr; - Tcl_ObjType *tPtr; long i = 0; /* Initialized to avoid compiler warning. */ - int isDouble, result; + int result; /* * Set stackPtr and stackTop from eePtr. @@ -4039,36 +4001,26 @@ ExprSrandFunc(interp, eePtr, clientData) */ valuePtr = POP_OBJECT(); - tPtr = valuePtr->typePtr; - - if (tPtr == &tclIntType) { - i = valuePtr->internalRep.longValue; - } else { - result = Tcl_GetLongFromObj((Tcl_Interp *) NULL, valuePtr, &i); - if (result != TCL_OK) { - /* - * See if the operand can be interpreted as a double in order to - * improve the error message. - */ - isDouble = 1; - if (valuePtr->typePtr != &tclDoubleType) { - char *s = Tcl_GetString(valuePtr); - double d; - - if (Tcl_GetDouble((Tcl_Interp *) NULL, s, &d) != TCL_OK) { - isDouble = 0; - } - } + if (VerifyExprObjType(interp, valuePtr) != TCL_OK) { + result = TCL_ERROR; + goto badValue; + } - Tcl_ResetResult(interp); - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "can't use ", - (isDouble? "floating-point value":"non-numeric string"), - " as argument to srand", (char *) NULL); - Tcl_DecrRefCount(valuePtr); - DECACHE_STACK_INFO(); - return result; - } + if (valuePtr->typePtr == &tclIntType) { + i = valuePtr->internalRep.longValue; + } else { + /* + * At this point, the only other possible type is double + */ + Tcl_ResetResult(interp); + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "can't use floating-point value as argument to srand", + (char *) NULL); + badValue: + Tcl_DecrRefCount(valuePtr); + DECACHE_STACK_INFO(); + return TCL_ERROR; } /* @@ -4132,10 +4084,9 @@ ExprCallMathFunc(interp, eePtr, objc, objv) Tcl_Value args[MAX_MATH_ARGS]; /* Arguments for function call. */ Tcl_Value funcResult; /* Result of function call as Tcl_Value. */ register Tcl_Obj *valuePtr; - Tcl_ObjType *tPtr; long i; double d; - int j, k, length, result; + int j, k, result; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); Tcl_ResetResult(interp); @@ -4174,39 +4125,19 @@ ExprCallMathFunc(interp, eePtr, objc, objv) for (j = 1, k = 0; j < objc; j++, k++) { valuePtr = objv[j]; - tPtr = valuePtr->typePtr; - - if (tPtr == &tclIntType) { - i = valuePtr->internalRep.longValue; - } else if (tPtr == &tclDoubleType) { - d = valuePtr->internalRep.doubleValue; - } else { - /* - * Try to convert to int first then double. - */ - - char *s = Tcl_GetStringFromObj(valuePtr, &length); - - if (TclLooksLikeInt(s, length)) { - result = Tcl_GetLongFromObj((Tcl_Interp *) NULL, valuePtr, &i); - } else { - result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL, - valuePtr, &d); - } - if (result != TCL_OK) { - Tcl_AppendToObj(Tcl_GetObjResult(interp), - "argument to math function didn't have numeric value", -1); - goto done; - } - tPtr = valuePtr->typePtr; + + if (VerifyExprObjType(interp, valuePtr) != TCL_OK) { + result = TCL_ERROR; + goto done; } /* * Copy the object's numeric value to the argument record, * converting it if necessary. */ - - if (tPtr == &tclIntType) { + + if (valuePtr->typePtr == &tclIntType) { + i = valuePtr->internalRep.longValue; if (mathFuncPtr->argTypes[k] == TCL_DOUBLE) { args[k].type = TCL_DOUBLE; args[k].doubleValue = i; @@ -4215,6 +4146,7 @@ ExprCallMathFunc(interp, eePtr, objc, objv) args[k].intValue = i; } } else { + d = valuePtr->internalRep.doubleValue; if (mathFuncPtr->argTypes[k] == TCL_INT) { args[k].type = TCL_INT; args[k].intValue = (long) d; diff --git a/generic/tclGet.c b/generic/tclGet.c index 4e6f184..69cf503 100644 --- a/generic/tclGet.c +++ b/generic/tclGet.c @@ -11,7 +11,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclGet.c,v 1.4 1999/08/19 02:59:09 hobbs Exp $ + * RCS: @(#) $Id: tclGet.c,v 1.5 1999/12/04 06:15:41 hobbs Exp $ */ #include "tclInt.h" @@ -71,6 +71,7 @@ Tcl_GetInt(interp, string, intPtr) if (interp != (Tcl_Interp *) NULL) { Tcl_AppendResult(interp, "expected integer but got \"", string, "\"", (char *) NULL); + TclCheckBadOctal(interp, string); } return TCL_ERROR; } @@ -157,6 +158,7 @@ TclGetLong(interp, string, longPtr) if (interp != (Tcl_Interp *) NULL) { Tcl_AppendResult(interp, "expected integer but got \"", string, "\"", (char *) NULL); + TclCheckBadOctal(interp, string); } return TCL_ERROR; } diff --git a/generic/tclInt.h b/generic/tclInt.h index 0be91e1..f96ae87 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -11,7 +11,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.37 1999/11/10 02:51:56 hobbs Exp $ + * RCS: @(#) $Id: tclInt.h,v 1.38 1999/12/04 06:15:41 hobbs Exp $ */ #ifndef _TCLINT @@ -1544,6 +1544,8 @@ EXTERN int TclAccessInsertProc _ANSI_ARGS_((TclAccessProc_ *proc)); EXTERN void TclAllocateFreeObjects _ANSI_ARGS_((void)); EXTERN int TclArraySet _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *arrayNameObj, Tcl_Obj *arrayElemObj)); +EXTERN int TclCheckBadOctal _ANSI_ARGS_((Tcl_Interp *interp, + char *value)); EXTERN int TclCleanupChildren _ANSI_ARGS_((Tcl_Interp *interp, int numPids, Tcl_Pid *pidPtr, Tcl_Channel errorChan)); diff --git a/generic/tclObj.c b/generic/tclObj.c index e83d70a..5b3fec7 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -10,7 +10,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclObj.c,v 1.11 1999/11/10 02:51:57 hobbs Exp $ + * RCS: @(#) $Id: tclObj.c,v 1.12 1999/12/04 06:15:41 hobbs Exp $ */ #include "tclInt.h" @@ -1686,6 +1686,7 @@ SetIntFromAny(interp, objPtr) sprintf(buf, "expected integer but got \"%.50s\"", string); Tcl_ResetResult(interp); Tcl_AppendToObj(Tcl_GetObjResult(interp), buf, -1); + TclCheckBadOctal(interp, string); } return TCL_ERROR; } diff --git a/generic/tclParseExpr.c b/generic/tclParseExpr.c index ced85d7..b9c9d71 100644 --- a/generic/tclParseExpr.c +++ b/generic/tclParseExpr.c @@ -11,7 +11,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclParseExpr.c,v 1.5 1999/09/02 16:26:33 hobbs Exp $ + * RCS: @(#) $Id: tclParseExpr.c,v 1.6 1999/12/04 06:15:42 hobbs Exp $ */ #include "tclInt.h" @@ -1521,8 +1521,28 @@ GetLexeme(infoPtr) } if (termPtr != src) { /* - * src was the start of a valid integer. + * src was the start of a valid integer, but was it + * a bad octal? Stopping at a digit would cause that. */ + if (isdigit(UCHAR(*termPtr))) { /* INTL: digit. */ + /* + * We only want to report an error for the number, + * but we may have something like "08+1" + */ + if (interp != NULL) { + while (isdigit(UCHAR(*(++termPtr)))) {} /* INTL: digit. */ + Tcl_ResetResult(interp); + offset = termPtr - src; + c = src[offset]; + src[offset] = 0; + Tcl_AppendResult(interp, "\"", src, + "\" is an invalid octal number", + (char *) NULL); + src[offset] = c; + } + parsePtr->errorType = TCL_PARSE_BAD_NUMBER; + return TCL_ERROR; + } infoPtr->lexeme = LITERAL; infoPtr->start = src; diff --git a/generic/tclUtil.c b/generic/tclUtil.c index 0a6085b..8a7fcec 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -10,7 +10,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclUtil.c,v 1.13 1999/09/21 04:20:41 hobbs Exp $ + * RCS: @(#) $Id: tclUtil.c,v 1.14 1999/12/04 06:15:42 hobbs Exp $ */ #include "tclInt.h" @@ -2248,6 +2248,7 @@ TclGetIntForIndex(interp, objPtr, endValue, indexPtr) Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "bad index \"", bytes, "\": must be integer or end?-integer?", (char *) NULL); + TclCheckBadOctal(interp, bytes); } return TCL_ERROR; } @@ -2257,6 +2258,59 @@ TclGetIntForIndex(interp, objPtr, endValue, indexPtr) /* *---------------------------------------------------------------------- * + * TclCheckBadOctal -- + * + * This procedure checks for a bad octal value and appends a + * meaningful error to the interp's result. + * + * Results: + * 1 if the argument was a bad octal, else 0. + * + * Side effects: + * The interpreter's result is modified. + * + *---------------------------------------------------------------------- + */ + +int +TclCheckBadOctal(interp, value) + Tcl_Interp *interp; /* Interpreter to use for error reporting. + * If NULL, then no error message is left + * after errors. */ + char *value; /* String to check. */ +{ + register char *p = value; + + /* + * A frequent mistake is invalid octal values due to an unwanted + * leading zero. Try to generate a meaningful error message. + */ + + while (isspace(UCHAR(*p))) { /* INTL: ISO space. */ + p++; + } + if (*p == '+' || *p == '-') { + p++; + } + if (*p == '0') { + while (isdigit(UCHAR(*p))) { /* INTL: digit. */ + p++; + } + if (*p == '\0') { + /* Reached end of string */ + if (interp != NULL) { + Tcl_AppendResult(interp, " (looks like invalid octal number)", + (char *) NULL); + } + return 1; + } + } + return 0; +} + +/* + *---------------------------------------------------------------------- + * * Tcl_GetNameOfExecutable -- * * This procedure simply returns a pointer to the internal full |