diff options
author | dgp <dgp@users.sourceforge.net> | 2005-08-22 20:50:24 (GMT) |
---|---|---|
committer | dgp <dgp@users.sourceforge.net> | 2005-08-22 20:50:24 (GMT) |
commit | 5e0cb01cef51df89027d10f6648399a23472e3ee (patch) | |
tree | f9e8aba5c4074e0ff60a5fc9aa8a23f3285ec84c | |
parent | b4b2bf21e398bc053390e1267b62bc4db29c2ff4 (diff) | |
download | tcl-5e0cb01cef51df89027d10f6648399a23472e3ee.zip tcl-5e0cb01cef51df89027d10f6648399a23472e3ee.tar.gz tcl-5e0cb01cef51df89027d10f6648399a23472e3ee.tar.bz2 |
[kennykb_numerics_branch]
* generic/tclInt.h: New ACCEPT_NAN macro to mark code that supports
* generic/tclCmdAH.c: or disables accepting of the NaN value at
* generic/tclExecute.c: various points.
* generic/tclLink.c:
* generic/tclStrToD.c: Bug fix. Parsing of +/- Infinity was reversed.
* generic/tclBasic: Added [expr {entier(.)}]. Rewrote int(.)
and wide(.) to use the same guts, accepting all non-Inf doubles as
arguments.
* generic/tclInt.h: New routine TclInitBignumFromDouble.
* generic/tclStrToD.c: Modified to return code and write error message.
-rw-r--r-- | ChangeLog | 13 | ||||
-rw-r--r-- | generic/tclBasic.c | 86 | ||||
-rw-r--r-- | generic/tclCmdAH.c | 3 | ||||
-rw-r--r-- | generic/tclExecute.c | 10 | ||||
-rw-r--r-- | generic/tclInt.h | 11 | ||||
-rw-r--r-- | generic/tclLink.c | 9 | ||||
-rwxr-xr-x | generic/tclStrToD.c | 22 |
7 files changed, 80 insertions, 74 deletions
@@ -2,12 +2,21 @@ [kennykb_numerics_branch] + * generic/tclInt.h: New ACCEPT_NAN macro to mark code that supports + * generic/tclCmdAH.c: or disables accepting of the NaN value at + * generic/tclExecute.c: various points. + * generic/tclLink.c: + + * generic/tclStrToD.c: Bug fix. Parsing of +/- Infinity was reversed. + * generic/tclTestObj.c: Disabled unused [testconvertobj] command. - * generic/tclBasic: Added [expr {entier(.)}]. + * generic/tclBasic: Added [expr {entier(.)}]. Rewrote int(.) + and wide(.) to use the same guts, accepting all non-Inf doubles as + arguments. * generic/tclInt.h: New routine TclInitBignumFromDouble. - * generic/tclStrToD.c: + * generic/tclStrToD.c: Modified to return code and write error message. * generic/tclInt.h: TCL_WIDE_INT_IS_LONG implies NO_WIDE_TYPE. * generic/tclObj.c: Removed now unnecessary tests of the diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 7feb1e5..43eb53d 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.22 2005/08/22 15:48:26 dgp Exp $ + * RCS: @(#) $Id: tclBasic.c,v 1.136.2.23 2005/08/22 20:50:25 dgp Exp $ */ #include "tclInt.h" @@ -5189,7 +5189,9 @@ ExprEntierFunc(clientData, interp, objc, objv) /* Non-numeric argument */ return TCL_ERROR; } - TclInitBignumFromDouble(d, &big); + if (TclInitBignumFromDouble(interp, d, &big) != TCL_OK) { + return TCL_ERROR; + } Tcl_SetObjResult(interp, Tcl_NewBignumObj(&big)); return TCL_OK; } @@ -5203,7 +5205,7 @@ ExprIntFunc(clientData, interp, objc, objv) Tcl_Obj *CONST *objv; /* Actual parameter vector */ { long iResult; - double d; + Tcl_Obj *objPtr; #if 0 register Tcl_Obj *valuePtr; Tcl_Obj* oResult; @@ -5245,37 +5247,19 @@ ExprIntFunc(clientData, interp, objc, objv) } return TCL_ERROR; #else - if (objc != 2) { - MathFuncWrongNumArgs(interp, 2, objc, objv); - return TCL_ERROR; - } - if (Tcl_GetDoubleFromObj(interp, objv[1], &d) != TCL_OK) { - /* Non-numeric argument */ + if (ExprEntierFunc(NULL, interp, objc, objv) != TCL_OK) { return TCL_ERROR; } - if (Tcl_GetLongFromObj(NULL, objv[1], &iResult) != TCL_OK) { + objPtr = Tcl_GetObjResult(interp); + if (Tcl_GetLongFromObj(NULL, objPtr, &iResult) != TCL_OK) { + /* truncate the bignum; keep only bits in wide int range */ mp_int big; - if (Tcl_GetBignumFromObj(NULL, objv[1], &big) != TCL_OK) { - /* Argument is really a double; attempt conversion - * For compatibility, impose limitation rules. - * TODO: rethink this? */ - if ((d < (double) (long) LONG_MIN) - || (d > (double) (long) LONG_MAX)) { - CONST char *s = "integer value too large to represent"; - Tcl_SetObjResult(interp, Tcl_NewStringObj(s, -1)); - Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", s, NULL); - return TCL_ERROR; - } - iResult = (long) d; - } else { - /* truncate the bignum; keep only bits in long range */ - Tcl_Obj *objPtr; - mp_mod_2d(&big, (int) CHAR_BIT * sizeof(long), &big); - objPtr = Tcl_NewBignumObj(&big); - Tcl_IncrRefCount(objPtr); - Tcl_GetLongFromObj(NULL, objPtr, &iResult); - Tcl_DecrRefCount(objPtr); - } + Tcl_GetBignumFromObj(NULL, objPtr, &big); + mp_mod_2d(&big, (int) CHAR_BIT * sizeof(long), &big); + objPtr = Tcl_NewBignumObj(&big); + Tcl_IncrRefCount(objPtr); + Tcl_GetLongFromObj(NULL, objPtr, &iResult); + Tcl_DecrRefCount(objPtr); } Tcl_SetObjResult(interp, Tcl_NewLongObj(iResult)); return TCL_OK; @@ -5291,7 +5275,7 @@ ExprWideFunc(clientData, interp, objc, objv) Tcl_Obj *CONST *objv; /* Actual parameter vector */ { Tcl_WideInt wResult; - double d; + Tcl_Obj *objPtr; #if 0 register Tcl_Obj *valuePtr; Tcl_Obj* oResult; @@ -5333,37 +5317,19 @@ ExprWideFunc(clientData, interp, objc, objv) } return TCL_ERROR; #else - if (objc != 2) { - MathFuncWrongNumArgs(interp, 2, objc, objv); - return TCL_ERROR; - } - if (Tcl_GetDoubleFromObj(interp, objv[1], &d) != TCL_OK) { - /* Non-numeric argument */ + if (ExprEntierFunc(NULL, interp, objc, objv) != TCL_OK) { return TCL_ERROR; } - if (Tcl_GetWideIntFromObj(NULL, objv[1], &wResult) != TCL_OK) { + objPtr = Tcl_GetObjResult(interp); + if (Tcl_GetWideIntFromObj(NULL, objPtr, &wResult) != TCL_OK) { + /* truncate the bignum; keep only bits in wide int range */ mp_int big; - if (Tcl_GetBignumFromObj(NULL, objv[1], &big) != TCL_OK) { - /* Argument is really a double; attempt conversion - * For compatibility, impose limitation rules. - * TODO: rethink this? */ - if ((d < Tcl_WideAsDouble(LLONG_MIN)) - || (d > Tcl_WideAsDouble(LLONG_MAX))) { - CONST char *s = "integer value too large to represent"; - Tcl_SetObjResult(interp, Tcl_NewStringObj(s, -1)); - Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", s, NULL); - return TCL_ERROR; - } - wResult = (Tcl_WideInt) d; - } else { - /* truncate the bignum; keep only bits in wide int range */ - Tcl_Obj *objPtr; - mp_mod_2d(&big, (int) CHAR_BIT * sizeof(Tcl_WideInt), &big); - objPtr = Tcl_NewBignumObj(&big); - Tcl_IncrRefCount(objPtr); - Tcl_GetWideIntFromObj(NULL, objPtr, &wResult); - Tcl_DecrRefCount(objPtr); - } + Tcl_GetBignumFromObj(NULL, objPtr, &big); + mp_mod_2d(&big, (int) CHAR_BIT * sizeof(Tcl_WideInt), &big); + objPtr = Tcl_NewBignumObj(&big); + Tcl_IncrRefCount(objPtr); + Tcl_GetWideIntFromObj(NULL, objPtr, &wResult); + Tcl_DecrRefCount(objPtr); } Tcl_SetObjResult(interp, Tcl_NewWideIntObj(wResult)); return TCL_OK; diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index f837892..dbec394 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.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: tclCmdAH.c,v 1.57.2.5 2005/08/02 18:15:12 dgp Exp $ + * RCS: @(#) $Id: tclCmdAH.c,v 1.57.2.6 2005/08/22 20:50:25 dgp Exp $ */ #include "tclInt.h" @@ -2294,6 +2294,7 @@ Tcl_FormatObjCmd(dummy, interp, objc, objv) case 'G': if (Tcl_GetDoubleFromObj(interp, /* INTL: Tcl source. */ objv[objIndex], &doubleValue) != TCL_OK) { + /*TODO: figure out ACCEPT_NAN */ goto fmtError; } whichValue = DOUBLE_VALUE; diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 9f97fdb..e34d780 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.30 2005/08/22 03:49:39 dgp Exp $ + * RCS: @(#) $Id: tclExecute.c,v 1.167.2.31 2005/08/22 20:50:25 dgp Exp $ */ #include "tclInt.h" @@ -4678,11 +4678,13 @@ TclExecuteByteCode(interp, codePtr) valuePtr = *(tosPtr - 1); result = Tcl_GetDoubleFromObj(NULL, valuePtr, &d1); if (result != TCL_OK) { +#ifdef ACCEPT_NAN if (valuePtr->typePtr == &tclDoubleType) { /* NaN first argument -> result is also NaN */ result = TCL_OK; NEXT_INST_F(1, 1, 0); } +#endif TRACE(("%.20s %.20s => ILLEGAL 1st TYPE %s\n", O2S(value2Ptr), O2S(valuePtr), (valuePtr->typePtr? valuePtr->typePtr->name: "null"))); @@ -4691,12 +4693,14 @@ TclExecuteByteCode(interp, codePtr) } result = Tcl_GetDoubleFromObj(NULL, value2Ptr, &d2); if (result != TCL_OK) { +#ifdef ACCEPT_NAN if (value2Ptr->typePtr == &tclDoubleType) { /* NaN second argument -> result is also NaN */ objResultPtr = value2Ptr; result = TCL_OK; NEXT_INST_F(1, 2, 1); } +#endif TRACE(("%.20s %.20s => ILLEGAL 2nd TYPE %s\n", O2S(value2Ptr), O2S(valuePtr), (value2Ptr->typePtr? value2Ptr->typePtr->name: "null"))); @@ -5082,6 +5086,7 @@ TclExecuteByteCode(interp, codePtr) result = Tcl_GetDoubleFromObj(NULL, valuePtr, &d); if ((result == TCL_OK) || valuePtr->typePtr == &tclDoubleType) { /* Value is now numeric (including NaN) */ +#ifdef ACCEPT_NAN if (result != TCL_OK) { /* Value is NaN */ if (*pc == INST_BITNOT) { @@ -5091,6 +5096,7 @@ TclExecuteByteCode(interp, codePtr) /* -NaN => NaN */ NEXT_INST_F(1, 0, 0); } +#endif if (valuePtr->typePtr == &tclDoubleType) { if (*pc == INST_BITNOT) { /* ~ arg must be an integer */ @@ -5310,7 +5316,7 @@ TclExecuteByteCode(interp, codePtr) result = Tcl_GetDoubleFromObj(NULL, valuePtr, &d); if ((result == TCL_OK) || valuePtr->typePtr == &tclDoubleType) { /* Value is now numeric (including NaN) */ -#if 0 +#ifndef ACCEPT_NAN if ((*pc == INST_TRY_CVT_TO_NUMERIC) && (result != TCL_OK)) { /* Numeric conversion of NaN -> error */ CONST char *s = "domain error: argument not in valid range"; diff --git a/generic/tclInt.h b/generic/tclInt.h index 76e3060..2162650 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -12,13 +12,18 @@ * 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.28 2005/08/22 15:48:26 dgp Exp $ + * RCS: @(#) $Id: tclInt.h,v 1.202.2.29 2005/08/22 20:50:26 dgp Exp $ */ #ifndef _TCLINT #define _TCLINT +/* + * Some numerics configuration options + */ + #define NO_WIDE_TYPE +#undef ACCEPT_NAN /* * Common include files needed by most of the Tcl source files are @@ -2012,8 +2017,8 @@ MODULE_SCOPE Tcl_Obj * TclIncrObjVar2 _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, Tcl_Obj *incrPtr, int flags)); MODULE_SCOPE void TclInitAlloc _ANSI_ARGS_((void)); -MODULE_SCOPE void TclInitBignumFromDouble _ANSI_ARGS_((double d, - mp_int *b)); +MODULE_SCOPE int TclInitBignumFromDouble _ANSI_ARGS_((Tcl_Interp *interp, + double d, mp_int *b)); MODULE_SCOPE void TclInitDbCkalloc _ANSI_ARGS_((void)); MODULE_SCOPE void TclInitDoubleConversion _ANSI_ARGS_((void)); MODULE_SCOPE void TclInitEmbeddedConfigurationInformation diff --git a/generic/tclLink.c b/generic/tclLink.c index f8a430d..4b71a35 100644 --- a/generic/tclLink.c +++ b/generic/tclLink.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: tclLink.c,v 1.8.6.2 2005/08/02 18:15:59 dgp Exp $ + * RCS: @(#) $Id: tclLink.c,v 1.8.6.3 2005/08/22 20:50:26 dgp Exp $ */ #include "tclInt.h" @@ -341,9 +341,16 @@ LinkTraceProc(clientData, interp, name1, name2, flags) case TCL_LINK_DOUBLE: if (Tcl_GetDoubleFromObj(NULL, valueObj, &linkPtr->lastValue.d) != TCL_OK) { +#ifdef ACCEPT_NAN + if (valueObj->typePtr != &tclDoubleType) { +#endif Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), TCL_GLOBAL_ONLY); return "variable must have real value"; +#ifdef ACCEPT_NAN + } + linkPtr->lastValue.d = valueObj->internalRep.doubleValue; +#endif } *(double *)(linkPtr->addr) = linkPtr->lastValue.d; break; diff --git a/generic/tclStrToD.c b/generic/tclStrToD.c index ba14cbd..67f3acb 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.25 2005/08/22 15:48:26 dgp Exp $ + * RCS: @(#) $Id: tclStrToD.c,v 1.1.2.26 2005/08/22 20:50:26 dgp Exp $ * *---------------------------------------------------------------------- */ @@ -992,9 +992,9 @@ TclParseNumber( Tcl_Interp* interp, case sINF: case sINFINITY: if ( signum ) { - objPtr->internalRep.doubleValue = HUGE_VAL; + objPtr->internalRep.doubleValue = - HUGE_VAL; } else { - objPtr->internalRep.doubleValue = -HUGE_VAL; + objPtr->internalRep.doubleValue = HUGE_VAL; } objPtr->typePtr = &tclDoubleType; break; @@ -2702,12 +2702,23 @@ TclFinalizeDoubleConversion() *---------------------------------------------------------------------- */ -void -TclInitBignumFromDouble(double d, /* Number to convert */ +int +TclInitBignumFromDouble(Tcl_Interp *interp, /* For error message */ + double d, /* Number to convert */ mp_int* b) /* Place to store the result */ { double fract; int expt; + + /* Infinite values can't convert to bignum */ + if ((d > DBL_MAX) || (d < -DBL_MAX)) { + if (interp != NULL) { + char *s = "integer value too large to represent"; + Tcl_SetObjResult(interp, Tcl_NewStringObj(s, -1)); + Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", s, NULL); + } + return TCL_ERROR; + } fract = frexp(d,&expt); if (expt <= 0) { mp_init(b); @@ -2733,6 +2744,7 @@ TclInitBignumFromDouble(double d, /* Number to convert */ b->sign = MP_NEG; } } + return TCL_OK; } /* |