summaryrefslogtreecommitdiffstats
path: root/generic
diff options
context:
space:
mode:
authorhobbs <hobbs>1999-12-04 06:15:40 (GMT)
committerhobbs <hobbs>1999-12-04 06:15:40 (GMT)
commit78a6d2f842a7ff7465cd0397481a93c78375096f (patch)
treec153fe1950b58db095afef4ac9ea58a5e73ebb2a /generic
parent5239dbb3790e4d48cee4dad3455a529b18b6c30b (diff)
downloadtcl-78a6d2f842a7ff7465cd0397481a93c78375096f.zip
tcl-78a6d2f842a7ff7465cd0397481a93c78375096f.tar.gz
tcl-78a6d2f842a7ff7465cd0397481a93c78375096f.tar.bz2
* tests/expr-old.test:
* tests/parseExpr.test: * tests/string.test: * generic/tclGet.c: * generic/tclInt.h: * generic/tclObj.c: * generic/tclParseExpr.c: * generic/tclUtil.c: * generic/tclExecute.c: added TclCheckBadOctal routine to enhance error message checking for when users use invalid octal numbers (like 08), as well as replumbed the Expr*Funcs with a new VerifyExprObjType to simplify type handling. * tests/expr.test: * generic/tclCompile.c: fixed 'bad code length' error for 'expr + {[incr]}' case, with new test case [Bug: 3736] and seg fault on 'expr + {[error]}' (different cause) that was caused by a correct optimization that didn't correctly track how it was modifying the source string in the opt. The optimization was removed, which means that: expr 1 + {[string length abc]} will be not be compiled inline as before, but this should be written: expr {1 + [string length abc]} which will be compiled inline for speed. This prevents expr 1 + {[mindless error]} from seg faulting, and only affects optimizations for degenerate cases [Bug: 3737]
Diffstat (limited to 'generic')
-rw-r--r--generic/tclCompile.c141
-rw-r--r--generic/tclExecute.c388
-rw-r--r--generic/tclGet.c4
-rw-r--r--generic/tclInt.h4
-rw-r--r--generic/tclObj.c3
-rw-r--r--generic/tclParseExpr.c24
-rw-r--r--generic/tclUtil.c56
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