diff options
author | dgp <dgp@users.sourceforge.net> | 2005-08-22 03:49:38 (GMT) |
---|---|---|
committer | dgp <dgp@users.sourceforge.net> | 2005-08-22 03:49:38 (GMT) |
commit | adbdb5660738ca39fd33e3aceafd17bc2446dd52 (patch) | |
tree | b089c07850da93a4df984135eaefa9108722e609 | |
parent | d7e67a5399199b4f3f2996d2ec6f9c0442f691b8 (diff) | |
download | tcl-adbdb5660738ca39fd33e3aceafd17bc2446dd52.zip tcl-adbdb5660738ca39fd33e3aceafd17bc2446dd52.tar.gz tcl-adbdb5660738ca39fd33e3aceafd17bc2446dd52.tar.bz2 |
[kennykb_numerics_branch]
* generic/tclInt.h: Moved TclParseInteger to tclUtil.c
* generic/tclParseExpr.c: and made it static.
* generic/tclUtil.c:
* generic/tclInt.decls: Moved TclExprFloatError to tclBasic.c and
* generic/tclBasic.c: made it static.
* generic/tclExecute.c:
* generitc/tclIntDecls.h: make genstubs
* generic/tclStubInit.c:
* generic/tclExecute.c: errno, IS_NAN, IS_INF, LLD no longer called in
this file; dropped/disabled support for them.
* generic/tclCompExpr.c: errno no longer used in these files;
* generic/tclParseExpr.c: dropped support "hack" for it.
* generic/tclStrToD.c: Disabled out of date support "hack" for errno.
* generic/tclBasic.c: Eliminated VerifyExprObjType. Initialize
errno to zero in OldMathFuncProc.
-rw-r--r-- | generic/tclBasic.c | 73 | ||||
-rw-r--r-- | generic/tclCompExpr.c | 17 | ||||
-rw-r--r-- | generic/tclExecute.c | 12 | ||||
-rw-r--r-- | generic/tclInt.decls | 8 | ||||
-rw-r--r-- | generic/tclInt.h | 4 | ||||
-rw-r--r-- | generic/tclIntDecls.h | 18 | ||||
-rw-r--r-- | generic/tclParseExpr.c | 19 | ||||
-rwxr-xr-x | generic/tclStrToD.c | 7 | ||||
-rw-r--r-- | generic/tclStubInit.c | 6 | ||||
-rw-r--r-- | generic/tclUtil.c | 60 |
10 files changed, 157 insertions, 67 deletions
diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 26b1f2d..2619d0e 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -13,7 +13,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclBasic.c,v 1.136.2.20 2005/08/19 21:55:20 dgp Exp $ + * RCS: @(#) $Id: tclBasic.c,v 1.136.2.21 2005/08/22 03:49:38 dgp Exp $ */ #include "tclInt.h" @@ -69,8 +69,11 @@ static int ExprUnaryFunc _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, Tcl_Obj *CONST *objv)); static int ExprWideFunc _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, Tcl_Obj *CONST *objv)); +#if 0 static int VerifyExprObjType _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *objPtr)); +#endif +static void ExprFloatError _ANSI_ARGS_((Tcl_Interp *interp, double value)); static void MathFuncWrongNumArgs _ANSI_ARGS_((Tcl_Interp* interp, int expected, int actual, Tcl_Obj *CONST *objv)); @@ -2861,7 +2864,10 @@ OldMathFuncProc(clientData, interp, objc, objv) Tcl_Value args[MAX_MATH_ARGS]; Tcl_Value funcResult; int result; - int i, j, k; +#if 0 + int i; +#endif + int j, k; double d; /* Check argument count */ @@ -2996,6 +3002,7 @@ OldMathFuncProc(clientData, interp, objc, objv) /* Call the function */ + errno = 0; result = (*dataPtr->proc)(dataPtr->clientData, interp, args, &funcResult); if (result != TCL_OK) { @@ -3011,7 +3018,7 @@ OldMathFuncProc(clientData, interp, objc, objv) } else { d = funcResult.doubleValue; if (IS_NAN(d) || IS_INF(d)) { - TclExprFloatError(interp, d); + ExprFloatError(interp, d); return TCL_ERROR; } TclNewDoubleObj(valuePtr, d); @@ -4990,7 +4997,7 @@ ExprUnaryFunc(clientData, interp, objc, objv) dResult = (*func)(d); if ((errno != 0) || IS_NAN(dResult)) { if (errno != ERANGE || (dResult != 0.0 && !IS_INF(dResult))) { - TclExprFloatError(interp, dResult); + ExprFloatError(interp, dResult); return TCL_ERROR; } } @@ -5033,7 +5040,7 @@ ExprBinaryFunc(clientData, interp, objc, objv) dResult = (*func)(d1, d2); if ((errno != 0) || IS_NAN(dResult)) { if (errno != ERANGE || (dResult != 0.0 && !IS_INF(dResult))) { - TclExprFloatError(interp, dResult); + ExprFloatError(interp, dResult); return TCL_ERROR; } } @@ -5528,11 +5535,14 @@ ExprSrandFunc(clientData, interp, objc, objv) } valuePtr = objv[1]; + + /* TODO: error message reform? */ +#if 0 if (VerifyExprObjType(interp, valuePtr) != TCL_OK) { return TCL_ERROR; } +#endif - /* TODO: error message reform? */ if (Tcl_GetLongFromObj(interp, valuePtr, &i) != TCL_OK) { /* * At this point, the only other possible type is double @@ -5567,6 +5577,56 @@ ExprSrandFunc(clientData, interp, objc, objv) /* *---------------------------------------------------------------------- * + * ExprFloatError -- + * + * This procedure is called when an error occurs during a floating-point + * operation. It reads errno and sets interp->objResultPtr accordingly. + * + * Results: + * interp->objResultPtr is set to hold an error message. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static void +ExprFloatError(interp, value) + Tcl_Interp *interp; /* Where to store error message. */ + double value; /* Value returned after error; used to + * distinguish underflows from overflows. */ +{ + CONST char *s; + + if ((errno == EDOM) || IS_NAN(value)) { + s = "domain error: argument not in valid range"; + Tcl_SetObjResult(interp, Tcl_NewStringObj(s, -1)); + Tcl_SetErrorCode(interp, "ARITH", "DOMAIN", s, (char *) NULL); + } else if ((errno == ERANGE) || IS_INF(value)) { + if (value == 0.0) { + s = "floating-point value too small to represent"; + Tcl_SetObjResult(interp, Tcl_NewStringObj(s, -1)); + Tcl_SetErrorCode(interp, "ARITH", "UNDERFLOW", s, (char *) NULL); + } else { + s = "floating-point value too large to represent"; + Tcl_SetObjResult(interp, Tcl_NewStringObj(s, -1)); + Tcl_SetErrorCode(interp, "ARITH", "OVERFLOW", s, (char *) NULL); + } + } else { + char msg[64 + TCL_INTEGER_SPACE]; + + sprintf(msg, "unknown floating-point error, errno = %d", errno); + Tcl_SetObjResult(interp, Tcl_NewStringObj(msg, -1)); + Tcl_SetErrorCode(interp, "ARITH", "UNKNOWN", msg, (char *) NULL); + } +} + + +#if 0 +/* + *---------------------------------------------------------------------- + * * VerifyExprObjType -- * * This procedure is called by the math functions to verify that @@ -5637,6 +5697,7 @@ VerifyExprObjType(interp, objPtr) return TCL_ERROR; #endif } +#endif /* *---------------------------------------------------------------------- diff --git a/generic/tclCompExpr.c b/generic/tclCompExpr.c index 9df405d..2e88790 100644 --- a/generic/tclCompExpr.c +++ b/generic/tclCompExpr.c @@ -9,28 +9,13 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclCompExpr.c,v 1.25.2.3 2005/08/04 16:47:50 dgp Exp $ + * RCS: @(#) $Id: tclCompExpr.c,v 1.25.2.4 2005/08/22 03:49:39 dgp Exp $ */ #include "tclInt.h" #include "tclCompile.h" /* - * The stuff below is a bit of a hack so that this file can be used in - * environments that include no UNIX, i.e. no errno: just arrange to use the - * errno from tclExecute.c here. - */ - -#ifdef TCL_GENERIC_ONLY -#define NO_ERRNO_H -#endif - -#ifdef NO_ERRNO_H -extern int errno; /* Use errno from tclExecute.c. */ -#define ERANGE 34 -#endif - -/* * Boolean variable that controls whether expression compilation tracing is * enabled. */ diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 753cd49..9f97fdb 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.167.2.29 2005/08/19 21:55:21 dgp Exp $ + * RCS: @(#) $Id: tclExecute.c,v 1.167.2.30 2005/08/22 03:49:39 dgp Exp $ */ #include "tclInt.h" @@ -49,6 +49,7 @@ # define NO_ERRNO_H #endif /* !TCL_GENERIC_ONLY */ +#if 0 #ifdef NO_ERRNO_H int errno; # define EDOM 33 @@ -69,6 +70,7 @@ int errno; # define DBL_MAX 1.79769313486231570e+308 # endif /* MAXDOUBLE */ #endif /* !DBL_MAX */ +#endif /* * A mask (should be 2**n-1) that is used to work out when the bytecode engine @@ -141,12 +143,11 @@ long tclObjsFreed = 0; long tclObjsShared[TCL_MAX_SHARED_OBJ_STATS] = { 0, 0, 0, 0, 0 }; #endif /* TCL_COMPILE_STATS */ +#if 0 /* * Macros for testing floating-point values for certain special cases. Test * for not-a-number by comparing a value against itself; test for infinity by * comparing against the largest floating-point value. - * - * TODO: Eliminate these ? */ #ifdef _MSC_VER @@ -156,6 +157,7 @@ long tclObjsShared[TCL_MAX_SHARED_OBJ_STATS] = { 0, 0, 0, 0, 0 }; #define IS_NAN(f) ((f) != (f)) #define IS_INF(f) ( (f) > DBL_MAX || (f) < -DBL_MAX ) #endif +#endif /* * The new macro for ending an instruction; note that a reasonable C-optimiser @@ -333,13 +335,11 @@ long tclObjsShared[TCL_MAX_SHARED_OBJ_STATS] = { 0, 0, 0, 0, 0 }; (IS_INTEGER_TYPE(typePtr) || (typePtr) == &tclDoubleType) #define W0 Tcl_LongAsWide(0) -#endif /* * For tracing that uses wide values. */ #define LLD "%" TCL_LL_MODIFIER "d" -#if 0 #ifndef TCL_WIDE_INT_IS_LONG /* * Extract a double value from a general numeric object. @@ -6791,6 +6791,7 @@ GetOpcodeName(pc) } #endif /* TCL_COMPILE_DEBUG */ +#if 0 /* *---------------------------------------------------------------------- * @@ -6838,6 +6839,7 @@ TclExprFloatError(interp, value) Tcl_SetErrorCode(interp, "ARITH", "UNKNOWN", msg, (char *) NULL); } } +#endif #ifdef TCL_COMPILE_STATS /* diff --git a/generic/tclInt.decls b/generic/tclInt.decls index c83dca0..7f0bc81 100644 --- a/generic/tclInt.decls +++ b/generic/tclInt.decls @@ -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: tclInt.decls,v 1.84.2.10 2005/08/19 05:17:48 dgp Exp $ +# RCS: @(#) $Id: tclInt.decls,v 1.84.2.11 2005/08/22 03:49:39 dgp Exp $ library tcl @@ -87,9 +87,9 @@ declare 14 generic { # declare 15 generic { # void TclExpandParseValue(ParseValue *pvPtr, int needed) # } -declare 16 generic { - void TclExprFloatError(Tcl_Interp *interp, double value) -} +#declare 16 generic { +# void TclExprFloatError(Tcl_Interp *interp, double value) +#} # Removed in 8.4 #declare 17 generic { # int TclFileAttrsCmd(Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) diff --git a/generic/tclInt.h b/generic/tclInt.h index e9746b7..c50b760 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -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: tclInt.h,v 1.202.2.24 2005/08/19 21:55:21 dgp Exp $ + * RCS: @(#) $Id: tclInt.h,v 1.202.2.25 2005/08/22 03:49:39 dgp Exp $ */ #ifndef _TCLINT @@ -2059,8 +2059,10 @@ MODULE_SCOPE int TclParseNumber _ANSI_ARGS_((Tcl_Interp* interp, MODULE_SCOPE void TclParseInit _ANSI_ARGS_ ((Tcl_Interp *interp, CONST char *string, int numBytes, Tcl_Parse *parsePtr)); +#if 0 MODULE_SCOPE int TclParseInteger _ANSI_ARGS_((CONST char *string, int numBytes)); +#endif MODULE_SCOPE int TclParseWhiteSpace _ANSI_ARGS_((CONST char *src, int numBytes, Tcl_Parse *parsePtr, char *typePtr)); MODULE_SCOPE int TclProcessReturn _ANSI_ARGS_((Tcl_Interp *interp, diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h index 3a424fe..2fcb761 100644 --- a/generic/tclIntDecls.h +++ b/generic/tclIntDecls.h @@ -12,9 +12,9 @@ * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * <<<<<<< tclIntDecls.h - * RCS: @(#) $Id: tclIntDecls.h,v 1.75.2.10 2005/08/19 05:17:48 dgp Exp $ + * RCS: @(#) $Id: tclIntDecls.h,v 1.75.2.11 2005/08/22 03:49:40 dgp Exp $ ======= - * RCS: @(#) $Id: tclIntDecls.h,v 1.75.2.10 2005/08/19 05:17:48 dgp Exp $ + * RCS: @(#) $Id: tclIntDecls.h,v 1.75.2.11 2005/08/22 03:49:40 dgp Exp $ >>>>>>> 1.83 */ @@ -148,12 +148,7 @@ EXTERN void TclDeleteVars _ANSI_ARGS_((Interp * iPtr, EXTERN void TclDumpMemoryInfo _ANSI_ARGS_((FILE * outFile)); #endif /* Slot 15 is reserved */ -#ifndef TclExprFloatError_TCL_DECLARED -#define TclExprFloatError_TCL_DECLARED -/* 16 */ -EXTERN void TclExprFloatError _ANSI_ARGS_((Tcl_Interp * interp, - double value)); -#endif +/* Slot 16 is reserved */ /* Slot 17 is reserved */ /* Slot 18 is reserved */ /* Slot 19 is reserved */ @@ -1120,7 +1115,7 @@ typedef struct TclIntStubs { void *reserved13; void (*tclDumpMemoryInfo) _ANSI_ARGS_((FILE * outFile)); /* 14 */ void *reserved15; - void (*tclExprFloatError) _ANSI_ARGS_((Tcl_Interp * interp, double value)); /* 16 */ + void *reserved16; void *reserved17; void *reserved18; void *reserved19; @@ -1419,10 +1414,7 @@ extern TclIntStubs *tclIntStubsPtr; (tclIntStubsPtr->tclDumpMemoryInfo) /* 14 */ #endif /* Slot 15 is reserved */ -#ifndef TclExprFloatError -#define TclExprFloatError \ - (tclIntStubsPtr->tclExprFloatError) /* 16 */ -#endif +/* Slot 16 is reserved */ /* Slot 17 is reserved */ /* Slot 18 is reserved */ /* Slot 19 is reserved */ diff --git a/generic/tclParseExpr.c b/generic/tclParseExpr.c index 2e59c49a..b74b69d 100644 --- a/generic/tclParseExpr.c +++ b/generic/tclParseExpr.c @@ -12,27 +12,12 @@ * 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.23.2.10 2005/08/17 20:49:55 kennykb Exp $ + * RCS: @(#) $Id: tclParseExpr.c,v 1.23.2.11 2005/08/22 03:49:40 dgp Exp $ */ #include "tclInt.h" /* - * The stuff below is a bit of a hack so that this file can be used in - * environments that include no UNIX, i.e. no errno: just arrange to use the - * errno from tclExecute.c here. - */ - -#ifdef TCL_GENERIC_ONLY -#define NO_ERRNO_H -#endif - -#ifdef NO_ERRNO_H -extern int errno; /* Use errno from tclExecute.c. */ -#define ERANGE 34 -#endif - -/* * Boolean variable that controls whether expression parse tracing is enabled. */ @@ -1886,6 +1871,7 @@ GetLexeme(infoPtr) } } +#if 0 /* *---------------------------------------------------------------------- * @@ -1945,6 +1931,7 @@ TclParseInteger(string, numBytes) } return 0; } +#endif /* *---------------------------------------------------------------------- diff --git a/generic/tclStrToD.c b/generic/tclStrToD.c index 7333d4b..658177f 100755 --- a/generic/tclStrToD.c +++ b/generic/tclStrToD.c @@ -15,7 +15,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclStrToD.c,v 1.1.2.21 2005/08/17 21:39:01 kennykb Exp $ + * RCS: @(#) $Id: tclStrToD.c,v 1.1.2.22 2005/08/22 03:49:40 dgp Exp $ * *---------------------------------------------------------------------- */ @@ -29,6 +29,10 @@ #include <ctype.h> #include <tommath.h> +#if 0 +/* Hack is out of date. tclInt.h unconditionally #include's errno.h + * (via tclPort.h). + */ /* * The stuff below is a bit of a hack so that this file can be used in * environments that include no UNIX, i.e. no errno: just arrange to use the @@ -43,6 +47,7 @@ extern int errno; /* Use errno from tclExecute.c. */ # define ERANGE 34 #endif +#endif #if (FLT_RADIX == 2) && (DBL_MANT_DIG == 53) && (DBL_MAX_EXP == 1024) # define IEEE_FLOATING_POINT diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index 729173a..9487130 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -9,9 +9,9 @@ * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * <<<<<<< tclStubInit.c - * RCS: @(#) $Id: tclStubInit.c,v 1.109.2.13 2005/08/19 05:17:48 dgp Exp $ + * RCS: @(#) $Id: tclStubInit.c,v 1.109.2.14 2005/08/22 03:49:41 dgp Exp $ ======= - * RCS: @(#) $Id: tclStubInit.c,v 1.109.2.13 2005/08/19 05:17:48 dgp Exp $ + * RCS: @(#) $Id: tclStubInit.c,v 1.109.2.14 2005/08/22 03:49:41 dgp Exp $ >>>>>>> 1.121 */ @@ -99,7 +99,7 @@ TclIntStubs tclIntStubs = { NULL, /* 13 */ TclDumpMemoryInfo, /* 14 */ NULL, /* 15 */ - TclExprFloatError, /* 16 */ + NULL, /* 16 */ NULL, /* 17 */ NULL, /* 18 */ NULL, /* 19 */ diff --git a/generic/tclUtil.c b/generic/tclUtil.c index 8b1a532..667e308 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.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: tclUtil.c,v 1.51.2.16 2005/08/15 20:46:02 dgp Exp $ + * RCS: @(#) $Id: tclUtil.c,v 1.51.2.17 2005/08/22 03:49:41 dgp Exp $ */ #include "tclInt.h" @@ -87,6 +87,8 @@ static void FreeProcessGlobalValue _ANSI_ARGS_(( ClientData clientData)); static void FreeThreadHash _ANSI_ARGS_((ClientData clientData)); static Tcl_HashTable * GetThreadHash _ANSI_ARGS_((Tcl_ThreadDataKey *keyPtr)); +static int ParseInteger _ANSI_ARGS_((CONST char *bytes, + int numBytes)); static int SetEndOffsetFromAny _ANSI_ARGS_((Tcl_Interp* interp, Tcl_Obj* objPtr)); static void UpdateStringOfEndOffset _ANSI_ARGS_((Tcl_Obj* objPtr)); @@ -2229,6 +2231,60 @@ TclLooksLikeInt(bytes, length) /* *---------------------------------------------------------------------- * + * ParseInteger -- + * + * Scans up to numBytes bytes starting at bytes, and checks whether the + * leading bytes look like an integer's string representation. + * + * Results: + * Returns 0 if the leading bytes do not look like an integer. + * Otherwise, returns the number of bytes examined that look like an + * integer. This may be less than numBytes if the integer is only the + * leading part of the string. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +ParseInteger(bytes, numBytes) + CONST char *bytes; /* The string to examine. */ + int numBytes; /* Max number of bytes to scan. */ +{ + register CONST char *p = bytes; + + /* Take care of introductory "0x". */ + if ((numBytes > 1) && (p[0] == '0') && ((p[1] == 'x') || (p[1] == 'X'))) { + int scanned; + Tcl_UniChar ch; + + p += 2; + numBytes -= 2; + scanned = TclParseHex(p, numBytes, &ch); + if (scanned) { + return scanned+2; + } + + /* Recognize the 0 as valid integer, but x is left behind. */ + return 1; + } + while (numBytes && isdigit(UCHAR(*p))) { /* INTL: digit */ + numBytes--; p++; + } + if (numBytes == 0) { + return (p - bytes); + } + if ((*p != '.') && (*p != 'e') && (*p != 'E')) { + return (p - bytes); + } + return 0; +} + +/* + *---------------------------------------------------------------------- + * * TclGetIntForIndex -- * * This function returns an integer corresponding to the list index held @@ -2288,7 +2344,7 @@ TclGetIntForIndex(interp, objPtr, endValue, indexPtr) if ((*p == '+') || (*p == '-')) { p++; length--; } - opIdx = TclParseInteger(p, length) + (int) (p-bytes); + opIdx = ParseInteger(p, length) + (int) (p-bytes); if (opIdx) { int code, first, second; char savedOp = bytes[opIdx]; |