diff options
-rw-r--r-- | ChangeLog | 11 | ||||
-rw-r--r-- | generic/tclBasic.c | 134 | ||||
-rw-r--r-- | generic/tclInt.h | 17 | ||||
-rw-r--r-- | generic/tclObj.c | 55 |
4 files changed, 121 insertions, 96 deletions
@@ -1,3 +1,14 @@ +2005-10-03 Don Porter <dgp@users.sourceforge.net> + + [kennykb-numerics-branch] + + * generic/tclBasic.c: Re-implemented ExprRoundFunc to use + TclGetNumberFromObj. + + * generic/tclInt.h: Added new routine TclGetNumberFromObj to + * generic/tclObj.c: provide efficient access to the actual + internal rep of a numeric Tcl_Obj without conversions. + 2005-09-30 Don Porter <dgp@users.sourceforge.net> [kennykb-numerics-branch] diff --git a/generic/tclBasic.c b/generic/tclBasic.c index fcd7910..a957085 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.35 2005/09/16 19:29:02 dgp Exp $ + * RCS: @(#) $Id: tclBasic.c,v 1.136.2.36 2005/10/03 15:50:19 dgp Exp $ */ #include "tclInt.h" @@ -5591,114 +5591,60 @@ ExprRoundFunc(clientData, interp, objc, objv) int objc; /* Actual parameter count */ Tcl_Obj *CONST *objv; /* Parameter vector */ { - Tcl_Obj *valuePtr; - double d, fractPart, intPart; - mp_int big; -#if 0 - double i, f; - Tcl_Obj *resPtr; -#endif - - /* - * Check the argument count. - */ + double d; + ClientData ptr; + int type; if (objc != 2) { MathFuncWrongNumArgs(interp, 1, objc, objv); return TCL_ERROR; } - valuePtr = objv[1]; - - /* - * Coerce the argument to a number. Integers are already rounded. - */ -#if 0 - if (VerifyExprObjType(interp, valuePtr) != TCL_OK) { + if (TclGetNumberFromObj(interp, objv[1], &ptr, &type) != TCL_OK) { return TCL_ERROR; } - if ((valuePtr->typePtr == &tclIntType) || - (valuePtr->typePtr == &tclWideIntType)) { - Tcl_SetObjResult(interp, valuePtr); - return TCL_OK; - } - GET_DOUBLE_VALUE(d, valuePtr, valuePtr->typePtr); - - /* - * Round the number to the nearest integer. I'd like to use round(), but - * it's C99 (or BSD), and not yet universal. - */ - - d = valuePtr->internalRep.doubleValue; - f = modf(d, &i); - if (d < 0.0) { - if (f <= -0.5) { - i += -1.0; - } - if (i <= Tcl_WideAsDouble(LLONG_MIN)) { - goto tooLarge; - } else if (d <= (double) LONG_MIN) { - resPtr = Tcl_NewWideIntObj(Tcl_DoubleAsWide(i)); - } else { - resPtr = Tcl_NewLongObj((long) i); - } - } else { - if (f >= 0.5) { - i += 1.0; - } - if (i >= Tcl_WideAsDouble(LLONG_MAX)) { - goto tooLarge; - } else if (i >= (double) LONG_MAX) { - resPtr = Tcl_NewWideIntObj(Tcl_DoubleAsWide(i)); - } else { - resPtr = Tcl_NewLongObj((long) i); - } - } - Tcl_SetObjResult(interp, resPtr); - return TCL_OK; - - /* - * Error return: result cannot be represented as an integer. - */ + if (type == TCL_NUMBER_DOUBLE) { + double fractPart, intPart; + long max = LONG_MAX, min = LONG_MIN; - tooLarge: - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "integer value too large to represent", -1)); - Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", - "integer value too large to represent", (char *) NULL); - - return TCL_ERROR; -#else - if (Tcl_GetDoubleFromObj(interp, valuePtr, &d) != TCL_OK) { - /* Non-numeric */ - return TCL_ERROR; - } - if (Tcl_GetBignumFromObj(NULL, valuePtr, &big) == TCL_OK) { - /* Integers are already rounded */ - mp_clear(&big); - Tcl_SetObjResult(interp, valuePtr); - return TCL_OK; - } - fractPart = modf(d, &intPart); - if (fractPart == 0.0) { - if (TclInitBignumFromDouble(interp, d, &big) != TCL_OK) { - return TCL_ERROR; - } - } else { - if (TclInitBignumFromDouble(interp, intPart, &big) != TCL_OK) { - return TCL_ERROR; + fractPart = modf(*((CONST double *)ptr), &intPart); + if (fractPart <= -0.5) { + min++; + } else if (fractPart >= 0.5) { + max--; } - if (fractPart < 0.0) { + if ((intPart > (double)max) || (intPart < (double)min)) { + mp_int big; + if (TclInitBignumFromDouble(interp, intPart, &big) != TCL_OK) { + /* Infinity */ + return TCL_ERROR; + } if (fractPart <= -0.5) { mp_sub_d(&big, 1, &big); + } else if (fractPart >= 0.5) { + mp_add_d(&big, 1, &big); } - } else if (fractPart >= 0.5) { - mp_add_d(&big, 1, &big); + Tcl_SetObjResult(interp, Tcl_NewBignumObj(&big)); + return TCL_OK; + } else { + long result = (long)intPart; + if (fractPart <= -0.5) { + result--; + } else if (fractPart >= 0.5) { + result++; + } + Tcl_SetObjResult(interp, Tcl_NewLongObj(result)); + return TCL_OK; } } - Tcl_SetObjResult(interp, Tcl_NewBignumObj(&big)); - return TCL_OK; -#endif + if (type != TCL_NUMBER_NAN) { + /* All integers are already rounded */ + Tcl_SetObjResult(interp, objv[1]); + return TCL_OK; + } + /* Get the error message for NaN */ + Tcl_GetDoubleFromObj(interp, objv[1], &d); + return TCL_ERROR; } static int diff --git a/generic/tclInt.h b/generic/tclInt.h index d71dadb..c098a11 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.40 2005/09/16 19:29:02 dgp Exp $ + * RCS: @(#) $Id: tclInt.h,v 1.202.2.41 2005/10/03 15:50:19 dgp Exp $ */ #ifndef _TCLINT @@ -1905,6 +1905,18 @@ typedef struct ProcessGlobalValue { /* Use [scan] rules dealing with 0? prefixes */ /* + *---------------------------------------------------------------------- + * Type values TclGetNumberFromObj + *---------------------------------------------------------------------- + */ + +#define TCL_NUMBER_LONG 1 +#define TCL_NUMBER_WIDE 2 +#define TCL_NUMBER_BIG 3 +#define TCL_NUMBER_DOUBLE 4 +#define TCL_NUMBER_NAN 5 + +/* *---------------------------------------------------------------- * Variables shared among Tcl modules but not used by the outside world. *---------------------------------------------------------------- @@ -2049,6 +2061,9 @@ MODULE_SCOPE int TclGetEncodingFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_Encoding *encodingPtr); MODULE_SCOPE int TclGetNamespaceFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_Namespace **nsPtrPtr); +MODULE_SCOPE int TclGetNumberFromObj(Tcl_Interp *interp, + Tcl_Obj *objPtr, ClientData *clientDataPtr, + int *typePtr); MODULE_SCOPE int TclGetOpenModeEx(Tcl_Interp *interp, CONST char *modeString, int *seekFlagPtr, int *binaryPtr); diff --git a/generic/tclObj.c b/generic/tclObj.c index f573741..f05ebba 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.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: tclObj.c,v 1.72.2.39 2005/09/27 18:42:54 dgp Exp $ + * RCS: @(#) $Id: tclObj.c,v 1.72.2.40 2005/10/03 15:50:19 dgp Exp $ */ #include "tclInt.h" @@ -2936,6 +2936,59 @@ TclSetBignumIntRep(objPtr, bignumValue) /* *---------------------------------------------------------------------- * + * TclGetNumberFromObj -- + * + * Results: + * + * Side effects: + * + *---------------------------------------------------------------------- + */ + +int TclGetNumberFromObj(interp, objPtr, clientDataPtr, typePtr) + Tcl_Interp *interp; + Tcl_Obj *objPtr; + ClientData *clientDataPtr; + int *typePtr; +{ + do { + if (objPtr->typePtr == &tclDoubleType) { + if (TclIsNaN(objPtr->internalRep.doubleValue)) { + *typePtr = TCL_NUMBER_NAN; + } else { + *typePtr = TCL_NUMBER_DOUBLE; + } + *clientDataPtr = &(objPtr->internalRep.doubleValue); + return TCL_OK; + } + if (objPtr->typePtr == &tclIntType) { + *typePtr = TCL_NUMBER_LONG; + *clientDataPtr = &(objPtr->internalRep.longValue); + return TCL_OK; + } + if (objPtr->typePtr == &tclBignumType) { + static Tcl_ThreadDataKey bignumKey; + mp_int *bigPtr = Tcl_GetThreadData(&bignumKey, (int)sizeof(mp_int)); + UNPACK_BIGNUM( objPtr, *bigPtr ); + *typePtr = TCL_NUMBER_BIG; + *clientDataPtr = bigPtr; + return TCL_OK; + } +#ifndef NO_WIDE_TYPE + if (objPtr->typePtr == &tclWideIntType) { + *typePtr = TCL_NUMBER_WIDE; + *clientDataPtr = &(objPtr->internalRep.wideValue); + return TCL_OK; + } +#endif + } while (TCL_OK == + TclParseNumber(interp, objPtr, "number", NULL, -1, NULL, 0)); + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * * Tcl_DbIncrRefCount -- * * This procedure is normally called when debugging: i.e., when |