summaryrefslogtreecommitdiffstats
path: root/generic
diff options
context:
space:
mode:
authordgp <dgp@users.sourceforge.net>2005-10-08 14:42:44 (GMT)
committerdgp <dgp@users.sourceforge.net>2005-10-08 14:42:44 (GMT)
commit76faac0f28fe9661f23ff9e35f44df1d899420e5 (patch)
tree7e3de1d0523d70328cfd81d9864b897058823d34 /generic
parent98a6fcad96289a40b501fbd2095387a245fd804d (diff)
downloadtcl-76faac0f28fe9661f23ff9e35f44df1d899420e5.zip
tcl-76faac0f28fe9661f23ff9e35f44df1d899420e5.tar.gz
tcl-76faac0f28fe9661f23ff9e35f44df1d899420e5.tar.bz2
TIP#237 IMPLEMENTATION
[kennykb-numerics-branch] Resynchronized with the HEAD; at this checkpoint [-rkennykb-numerics-branch-20051008], the HEAD and kennykb-numerics-branch contain identical code.
Diffstat (limited to 'generic')
-rw-r--r--generic/tcl.decls17
-rw-r--r--generic/tcl.h8
-rw-r--r--generic/tclBasic.c996
-rw-r--r--generic/tclCmdAH.c5
-rw-r--r--generic/tclCmdIL.c19
-rw-r--r--generic/tclCmdMZ.c50
-rw-r--r--generic/tclCompCmds.c16
-rw-r--r--generic/tclCompExpr.c17
-rw-r--r--generic/tclDecls.h50
-rw-r--r--generic/tclDictObj.c72
-rw-r--r--generic/tclExecute.c2665
-rw-r--r--generic/tclInt.decls24
-rw-r--r--generic/tclInt.h121
-rw-r--r--generic/tclIntDecls.h47
-rw-r--r--generic/tclLink.c9
-rw-r--r--generic/tclObj.c1271
-rw-r--r--generic/tclParseExpr.c130
-rw-r--r--generic/tclProc.c14
-rw-r--r--generic/tclScan.c234
-rwxr-xr-xgeneric/tclStrToD.c2562
-rw-r--r--generic/tclStringObj.c127
-rw-r--r--generic/tclStubInit.c21
-rw-r--r--generic/tclTest.c145
-rw-r--r--generic/tclTestObj.c8
-rw-r--r--generic/tclThreadTest.c4
-rw-r--r--generic/tclTomMath.h13
-rw-r--r--generic/tclTomMathInterface.c82
-rw-r--r--generic/tclUtil.c86
-rw-r--r--generic/tclVar.c131
-rw-r--r--generic/tommath.h6
30 files changed, 5655 insertions, 3295 deletions
diff --git a/generic/tcl.decls b/generic/tcl.decls
index b6417ff..3254f2c 100644
--- a/generic/tcl.decls
+++ b/generic/tcl.decls
@@ -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: tcl.decls,v 1.113 2005/08/24 17:56:23 andreas_kupries Exp $
+# RCS: @(#) $Id: tcl.decls,v 1.114 2005/10/08 14:42:44 dgp Exp $
library tcl
@@ -2003,28 +2003,31 @@ declare 557 generic {
declare 558 generic {
int Tcl_GetBignumFromObj( Tcl_Interp* interp, Tcl_Obj* obj, mp_int* value )
}
+declare 559 generic {
+ int Tcl_GetBignumAndClearObj( Tcl_Interp* interp, Tcl_Obj* obj, mp_int* value )
+}
# TIP #208:
-declare 559 generic {
+declare 560 generic {
int Tcl_TruncateChannel(Tcl_Channel chan, Tcl_WideInt length)
}
-declare 560 generic {
+declare 561 generic {
Tcl_DriverTruncateProc *Tcl_ChannelTruncateProc(
Tcl_ChannelType *chanTypePtr)
}
# TIP#219 (Tcl Channel Reflection API) akupries
-declare 561 generic {
+declare 562 generic {
void Tcl_SetChannelErrorInterp (Tcl_Interp* interp, Tcl_Obj* msg)
}
-declare 562 generic {
+declare 563 generic {
void Tcl_GetChannelErrorInterp (Tcl_Interp* interp, Tcl_Obj** msg)
}
-declare 563 generic {
+declare 564 generic {
void Tcl_SetChannelError (Tcl_Channel chan, Tcl_Obj* msg)
}
-declare 564 generic {
+declare 565 generic {
void Tcl_GetChannelError (Tcl_Channel chan, Tcl_Obj** msg)
}
diff --git a/generic/tcl.h b/generic/tcl.h
index f75ae6f..0d43309 100644
--- a/generic/tcl.h
+++ b/generic/tcl.h
@@ -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: tcl.h,v 1.203 2005/09/13 21:23:51 dgp Exp $
+ * RCS: @(#) $Id: tcl.h,v 1.204 2005/10/08 14:42:44 dgp Exp $
*/
#ifndef _TCL
@@ -770,10 +770,10 @@ typedef struct Tcl_Obj {
} twoPtrValue;
struct { /* - internal rep as a wide int, tightly
* packed fields */
- VOID *digits; /* Pointer to digits */
- unsigned long misc; /* Alloc, used, and signum packed into a
+ VOID *ptr; /* Pointer to digits */
+ unsigned long value;/* Alloc, used, and signum packed into a
* single word */
- } bignumValue;
+ } ptrAndLongRep;
} internalRep;
} Tcl_Obj;
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index 0198a4e..b2bef10 100644
--- a/generic/tclBasic.c
+++ b/generic/tclBasic.c
@@ -13,13 +13,14 @@
* 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.174 2005/09/15 16:40:02 dgp Exp $
+ * RCS: @(#) $Id: tclBasic.c,v 1.175 2005/10/08 14:42:44 dgp Exp $
*/
#include "tclInt.h"
#include "tclCompile.h"
#include <float.h>
#include <math.h>
+#include "tommath.h"
/*
* The following structure defines the client data for a math function
@@ -37,90 +38,48 @@ typedef struct OldMathFuncData {
* Static procedures in this file:
*/
-static char * CallCommandTraces(Interp *iPtr, Command *cmdPtr,
+static char * CallCommandTraces (Interp *iPtr, Command *cmdPtr,
CONST char *oldName, CONST char* newName, int flags);
-static void DeleteInterpProc(Tcl_Interp *interp);
-static void ProcessUnexpectedResult(Tcl_Interp *interp, int returnCode);
+static int CheckDoubleResult (Tcl_Interp *interp, double dResult);
+static void DeleteInterpProc (Tcl_Interp *interp);
+static void ProcessUnexpectedResult (Tcl_Interp *interp, int returnCode);
-static int OldMathFuncProc(ClientData clientData, Tcl_Interp *interp,
+static int OldMathFuncProc (ClientData clientData, Tcl_Interp *interp,
int argc, Tcl_Obj *CONST *objv);
-static void OldMathFuncDeleteProc(ClientData clientData);
+static void OldMathFuncDeleteProc (ClientData clientData);
-static int ExprAbsFunc(ClientData clientData, Tcl_Interp *interp,
+static int ExprAbsFunc (ClientData clientData, Tcl_Interp *interp,
int argc, Tcl_Obj *CONST *objv);
-static int ExprBinaryFunc(ClientData clientData, Tcl_Interp *interp,
+static int ExprBinaryFunc (ClientData clientData, Tcl_Interp *interp,
int argc, Tcl_Obj *CONST *objv);
-static int ExprBoolFunc(ClientData clientData, Tcl_Interp *interp,
+static int ExprBoolFunc (ClientData clientData, Tcl_Interp *interp,
int argc, Tcl_Obj *CONST *objv);
-static int ExprDoubleFunc(ClientData clientData, Tcl_Interp *interp,
+static int ExprCeilFunc (ClientData clientData, Tcl_Interp *interp,
int argc, Tcl_Obj *CONST *objv);
-static int ExprIntFunc(ClientData clientData, Tcl_Interp *interp,
+static int ExprDoubleFunc (ClientData clientData, Tcl_Interp *interp,
int argc, Tcl_Obj *CONST *objv);
-static int ExprRandFunc(ClientData clientData, Tcl_Interp *interp,
+static int ExprEntierFunc (ClientData clientData, Tcl_Interp *interp,
int argc, Tcl_Obj *CONST *objv);
-static int ExprRoundFunc(ClientData clientData, Tcl_Interp *interp,
+static int ExprFloorFunc (ClientData clientData, Tcl_Interp *interp,
int argc, Tcl_Obj *CONST *objv);
-static int ExprSrandFunc(ClientData clientData, Tcl_Interp *interp,
+static int ExprIntFunc (ClientData clientData, Tcl_Interp *interp,
int argc, Tcl_Obj *CONST *objv);
-static int ExprUnaryFunc(ClientData clientData, Tcl_Interp *interp,
+static int ExprRandFunc (ClientData clientData, Tcl_Interp *interp,
int argc, Tcl_Obj *CONST *objv);
-static int ExprWideFunc(ClientData clientData, Tcl_Interp *interp,
+static int ExprRoundFunc (ClientData clientData, Tcl_Interp *interp,
int argc, Tcl_Obj *CONST *objv);
-static int VerifyExprObjType(Tcl_Interp *interp, Tcl_Obj *objPtr);
-
-static void MathFuncWrongNumArgs(Tcl_Interp* interp, int expected,
+static int ExprSqrtFunc (ClientData clientData, Tcl_Interp *interp,
+ int argc, Tcl_Obj *CONST *objv);
+static int ExprSrandFunc (ClientData clientData, Tcl_Interp *interp,
+ int argc, Tcl_Obj *CONST *objv);
+static int ExprUnaryFunc (ClientData clientData, Tcl_Interp *interp,
+ int argc, Tcl_Obj *CONST *objv);
+static int ExprWideFunc (ClientData clientData, Tcl_Interp *interp,
+ int argc, Tcl_Obj *CONST *objv);
+static void MathFuncWrongNumArgs (Tcl_Interp* interp, int expected,
int actual, Tcl_Obj *CONST *objv);
-#ifndef TCL_WIDE_INT_IS_LONG
-/*
- * Extract a double value from a general numeric object.
- */
-
-#define GET_DOUBLE_VALUE(doubleVar, objPtr, typePtr) \
- if ((typePtr) == &tclIntType) { \
- (doubleVar) = (double) (objPtr)->internalRep.longValue; \
- } else if ((typePtr) == &tclWideIntType) { \
- (doubleVar) = Tcl_WideAsDouble((objPtr)->internalRep.wideValue);\
- } else { \
- (doubleVar) = (objPtr)->internalRep.doubleValue; \
- }
-#else /* TCL_WIDE_INT_IS_LONG */
-#define GET_DOUBLE_VALUE(doubleVar, objPtr, typePtr) \
- if (((typePtr) == &tclIntType) || ((typePtr) == &tclWideIntType)) { \
- (doubleVar) = (double) (objPtr)->internalRep.longValue; \
- } else { \
- (doubleVar) = (objPtr)->internalRep.doubleValue; \
- }
-#endif /* TCL_WIDE_INT_IS_LONG */
-#define GET_WIDE_OR_INT(resultVar, objPtr, longVar, wideVar) \
- (resultVar) = Tcl_GetWideIntFromObj((Tcl_Interp *) NULL, (objPtr), \
- &(wideVar)); \
- if ((resultVar) == TCL_OK && (wideVar) >= Tcl_LongAsWide(LONG_MIN) \
- && (wideVar) <= Tcl_LongAsWide(LONG_MAX)) { \
- (objPtr)->typePtr = &tclIntType; \
- (objPtr)->internalRep.longValue = (longVar) \
- = Tcl_WideAsLong(wideVar); \
- }
-#define IS_INTEGER_TYPE(typePtr) \
- ((typePtr) == &tclIntType || (typePtr) == &tclWideIntType)
-#define IS_NUMERIC_TYPE(typePtr) \
- (IS_INTEGER_TYPE(typePtr) || (typePtr) == &tclDoubleType)
-
-/*
- * 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.
- */
-
-#ifdef _MSC_VER
-#define IS_NAN(f) (_isnan((f)))
-#define IS_INF(f) (!(_finite((f))))
-#else
-#define IS_NAN(f) ((f) != (f))
-#define IS_INF(f) (((f) > DBL_MAX) || ((f) < -DBL_MAX))
-#endif
-
extern TclStubs tclStubs;
/*
@@ -251,12 +210,13 @@ static BuiltinFuncDef BuiltinFuncTable[] = {
{ "::tcl::mathfunc::atan", ExprUnaryFunc, (ClientData) atan },
{ "::tcl::mathfunc::atan2", ExprBinaryFunc, (ClientData) atan2 },
{ "::tcl::mathfunc::bool", ExprBoolFunc, NULL },
- { "::tcl::mathfunc::ceil", ExprUnaryFunc, (ClientData) ceil },
+ { "::tcl::mathfunc::ceil", ExprCeilFunc, NULL },
{ "::tcl::mathfunc::cos", ExprUnaryFunc, (ClientData) cos },
{ "::tcl::mathfunc::cosh", ExprUnaryFunc, (ClientData) cosh },
{ "::tcl::mathfunc::double",ExprDoubleFunc, NULL },
+ { "::tcl::mathfunc::entier",ExprEntierFunc, NULL },
{ "::tcl::mathfunc::exp", ExprUnaryFunc, (ClientData) exp },
- { "::tcl::mathfunc::floor", ExprUnaryFunc, (ClientData) floor },
+ { "::tcl::mathfunc::floor", ExprFloorFunc, NULL },
{ "::tcl::mathfunc::fmod", ExprBinaryFunc, (ClientData) fmod },
{ "::tcl::mathfunc::hypot", ExprBinaryFunc, (ClientData) hypot },
{ "::tcl::mathfunc::int", ExprIntFunc, NULL },
@@ -267,7 +227,7 @@ static BuiltinFuncDef BuiltinFuncTable[] = {
{ "::tcl::mathfunc::round", ExprRoundFunc, NULL },
{ "::tcl::mathfunc::sin", ExprUnaryFunc, (ClientData) sin },
{ "::tcl::mathfunc::sinh", ExprUnaryFunc, (ClientData) sinh },
- { "::tcl::mathfunc::sqrt", ExprUnaryFunc, (ClientData) sqrt },
+ { "::tcl::mathfunc::sqrt", ExprSqrtFunc, NULL },
{ "::tcl::mathfunc::srand", ExprSrandFunc, NULL },
{ "::tcl::mathfunc::tan", ExprUnaryFunc, (ClientData) tan },
{ "::tcl::mathfunc::tanh", ExprUnaryFunc, (ClientData) tanh },
@@ -2873,7 +2833,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;
/*
@@ -2889,6 +2852,7 @@ OldMathFuncProc(clientData, interp, objc, objv)
* Convert arguments from Tcl_Obj's to Tcl_Value's.
*/
+#if 0
for (j = 1, k = 0; j < objc; ++j, ++k) {
valuePtr = objv[j];
if (VerifyExprObjType(interp, valuePtr) != TCL_OK) {
@@ -2939,11 +2903,75 @@ OldMathFuncProc(clientData, interp, objc, objv)
}
}
}
+#else
+ for (j = 1, k = 0; j < objc; ++j, ++k) {
+ valuePtr = objv[j];
+ result = Tcl_GetDoubleFromObj(NULL, valuePtr, &d);
+#ifdef ACCEPT_NAN
+ if ((result != TCL_OK) && (valuePtr->typePtr == &tclDoubleType)) {
+ d = valuePtr->internalRep.doubleValue;
+ result = TCL_OK;
+ }
+#endif
+ if (result != TCL_OK) {
+ /* Non-numeric argument */
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "argument to math function didn't have numeric value", -1));
+ TclCheckBadOctal(interp, Tcl_GetString(valuePtr));
+ return TCL_ERROR;
+ }
+
+ /*
+ * Copy the object's numeric value to the argument record,
+ * converting it if necessary.
+ *
+ * NOTE: no bignum support; use the new mathfunc interface for that
+ */
+
+ args[k].type = dataPtr->argTypes[k];
+ switch (args[k].type) {
+ case TCL_EITHER:
+ if (Tcl_GetLongFromObj(NULL, valuePtr, &(args[k].intValue))
+ == TCL_OK) {
+ args[k].type = TCL_INT;
+ break;
+ }
+ if (Tcl_GetWideIntFromObj(interp, valuePtr, &(args[k].wideValue))
+ == TCL_OK) {
+ args[k].type = TCL_WIDE_INT;
+ break;
+ }
+ args[k].type = TCL_DOUBLE;
+ /* FALLTHROUGH */
+
+ case TCL_DOUBLE:
+ args[k].doubleValue = d;
+ break;
+ case TCL_INT:
+ if (ExprIntFunc(NULL, interp, 2, &(objv[j-1])) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ valuePtr = Tcl_GetObjResult(interp);
+ Tcl_GetLongFromObj(NULL, valuePtr, &(args[k].intValue));
+ Tcl_ResetResult(interp);
+ break;
+ case TCL_WIDE_INT:
+ if (ExprWideFunc(NULL, interp, 2, &(objv[j-1])) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ valuePtr = Tcl_GetObjResult(interp);
+ Tcl_GetWideIntFromObj(NULL, valuePtr, &(args[k].wideValue));
+ Tcl_ResetResult(interp);
+ break;
+ }
+ }
+#endif
/*
* Call the function.
*/
+ errno = 0;
result = (*dataPtr->proc)(dataPtr->clientData, interp, args, &funcResult);
if (result != TCL_OK) {
return result;
@@ -2956,18 +2984,12 @@ OldMathFuncProc(clientData, interp, objc, objv)
if (funcResult.type == TCL_INT) {
TclNewLongObj(valuePtr, funcResult.intValue);
} else if (funcResult.type == TCL_WIDE_INT) {
- TclNewWideIntObj(valuePtr, funcResult.wideValue);
+ valuePtr = Tcl_NewWideIntObj(funcResult.wideValue);
} else {
- d = funcResult.doubleValue;
- if (IS_NAN(d) || IS_INF(d)) {
- TclExprFloatError(interp, d);
- return TCL_ERROR;
- }
- TclNewDoubleObj(valuePtr, d);
+ return CheckDoubleResult(interp, funcResult.doubleValue);
}
Tcl_SetObjResult(interp, valuePtr);
return TCL_OK;
-
}
/*
@@ -4191,64 +4213,18 @@ Tcl_ExprLong(interp, exprstring, ptr)
long *ptr; /* Where to store result. */
{
register Tcl_Obj *exprPtr;
- Tcl_Obj *resultPtr;
- int length = strlen(exprstring);
int result = TCL_OK;
-
- if (length > 0) {
- exprPtr = Tcl_NewStringObj(exprstring, length);
+ if (*exprstring == '\0') {
+ /* Legacy compatibility - return 0 for the zero-length string. */
+ *ptr = 0;
+ } else {
+ exprPtr = Tcl_NewStringObj(exprstring, -1);
Tcl_IncrRefCount(exprPtr);
- result = Tcl_ExprObj(interp, exprPtr, &resultPtr);
- if (result == TCL_OK) {
- /*
- * Store an integer based on the expression result.
- */
-
- if (resultPtr->typePtr == &tclIntType) {
- *ptr = resultPtr->internalRep.longValue;
- } else if (resultPtr->typePtr == &tclDoubleType) {
- *ptr = (long) resultPtr->internalRep.doubleValue;
- } else if (resultPtr->typePtr == &tclWideIntType) {
-#ifndef TCL_WIDE_INT_IS_LONG
- /*
- * See Tcl_GetIntFromObj for conversion comments.
- */
-
- Tcl_WideInt w = resultPtr->internalRep.wideValue;
-
- if ((w >= -(Tcl_WideInt)(ULONG_MAX))
- && (w <= (Tcl_WideInt)(ULONG_MAX))) {
- *ptr = Tcl_WideAsLong(w);
- } else {
- Tcl_SetResult(interp,
- "integer value too large to represent as non-long integer",
- TCL_STATIC);
- result = TCL_ERROR;
- }
-#else
- *ptr = resultPtr->internalRep.longValue;
-#endif
- } else {
- Tcl_SetResult(interp,
- "expression didn't have numeric value", TCL_STATIC);
- result = TCL_ERROR;
- }
- Tcl_DecrRefCount(resultPtr);/* discard the result object */
- } else {
- /*
- * Move the interpreter's object result to the string result, then
- * reset the object result.
- */
-
+ result = Tcl_ExprLongObj(interp, exprPtr, ptr);
+ Tcl_DecrRefCount(exprPtr);
+ if (result != TCL_OK) {
(void) Tcl_GetStringResult(interp);
}
- Tcl_DecrRefCount(exprPtr); /* discard the expression object */
- } else {
- /*
- * An empty string. Just set the result integer to 0.
- */
-
- *ptr = 0;
}
return result;
}
@@ -4261,64 +4237,19 @@ Tcl_ExprDouble(interp, exprstring, ptr)
double *ptr; /* Where to store result. */
{
register Tcl_Obj *exprPtr;
- Tcl_Obj *resultPtr;
- int length = strlen(exprstring);
int result = TCL_OK;
- if (length > 0) {
- exprPtr = Tcl_NewStringObj(exprstring, length);
+ if (*exprstring == '\0') {
+ /* Legacy compatibility - return 0 for the zero-length string. */
+ *ptr = 0.0;
+ } else {
+ exprPtr = Tcl_NewStringObj(exprstring, -1);
Tcl_IncrRefCount(exprPtr);
- result = Tcl_ExprObj(interp, exprPtr, &resultPtr);
- if (result == TCL_OK) {
- /*
- * Store a double based on the expression result.
- */
-
- if (resultPtr->typePtr == &tclIntType) {
- *ptr = (double) resultPtr->internalRep.longValue;
- } else if (resultPtr->typePtr == &tclDoubleType) {
- *ptr = resultPtr->internalRep.doubleValue;
- } else if (resultPtr->typePtr == &tclWideIntType) {
-#ifndef TCL_WIDE_INT_IS_LONG
- /*
- * See Tcl_GetIntFromObj for conversion comments.
- */
-
- Tcl_WideInt w = resultPtr->internalRep.wideValue;
-
- if ((w >= -(Tcl_WideInt)(ULONG_MAX))
- && (w <= (Tcl_WideInt)(ULONG_MAX))) {
- *ptr = (double) Tcl_WideAsLong(w);
- } else {
- Tcl_SetResult(interp,
- "integer value too large to represent as non-long integer",
- TCL_STATIC);
- result = TCL_ERROR;
- }
-#else
- *ptr = (double) resultPtr->internalRep.longValue;
-#endif
- } else {
- Tcl_SetResult(interp,
- "expression didn't have numeric value", TCL_STATIC);
- result = TCL_ERROR;
- }
- Tcl_DecrRefCount(resultPtr);/* discard the result object */
- } else {
- /*
- * Move the interpreter's object result to the string result, then
- * reset the object result.
- */
-
+ result = Tcl_ExprDoubleObj(interp, exprPtr, ptr);
+ Tcl_DecrRefCount(exprPtr); /* discard the expression object */
+ if (result != TCL_OK) {
(void) Tcl_GetStringResult(interp);
}
- Tcl_DecrRefCount(exprPtr); /* discard the expression object */
- } else {
- /*
- * An empty string. Just set the result double to 0.0.
- */
-
- *ptr = 0.0;
}
return result;
}
@@ -4385,22 +4316,42 @@ Tcl_ExprLongObj(interp, objPtr, ptr)
long *ptr; /* Where to store long result. */
{
Tcl_Obj *resultPtr;
- int result;
+ int result, type;
+ double d;
+ ClientData internalPtr;
result = Tcl_ExprObj(interp, objPtr, &resultPtr);
- if (result == TCL_OK) {
- if (resultPtr->typePtr == &tclIntType) {
- *ptr = resultPtr->internalRep.longValue;
- } else if (resultPtr->typePtr == &tclDoubleType) {
- *ptr = (long) resultPtr->internalRep.doubleValue;
- } else {
- result = Tcl_GetLongFromObj(interp, resultPtr, ptr);
- if (result != TCL_OK) {
- return result;
- }
+ if (result != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ if (TclGetNumberFromObj(interp, resultPtr, &internalPtr, &type) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ switch (type) {
+ case TCL_NUMBER_DOUBLE: {
+ mp_int big;
+ d = *((CONST double *)internalPtr);
+ Tcl_DecrRefCount(resultPtr);
+ if (TclInitBignumFromDouble(interp, d, &big) != TCL_OK) {
+ return TCL_ERROR;
}
- Tcl_DecrRefCount(resultPtr); /* discard the result object */
+ resultPtr = Tcl_NewBignumObj(&big);
+ /* FALLTHROUGH */
}
+ case TCL_NUMBER_LONG:
+ case TCL_NUMBER_WIDE:
+ case TCL_NUMBER_BIG:
+ result = Tcl_GetLongFromObj(interp, resultPtr, ptr);
+ break;
+
+ case TCL_NUMBER_NAN:
+ Tcl_GetDoubleFromObj(interp, resultPtr, &d);
+ result = TCL_ERROR;
+ }
+
+ Tcl_DecrRefCount(resultPtr); /* discard the result object */
return result;
}
@@ -4412,22 +4363,31 @@ Tcl_ExprDoubleObj(interp, objPtr, ptr)
double *ptr; /* Where to store double result. */
{
Tcl_Obj *resultPtr;
- int result;
+ int result, type;
+ ClientData internalPtr;
result = Tcl_ExprObj(interp, objPtr, &resultPtr);
+ if (result != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ result = TclGetNumberFromObj(interp, resultPtr, &internalPtr, &type);
if (result == TCL_OK) {
- if (resultPtr->typePtr == &tclIntType) {
- *ptr = (double) resultPtr->internalRep.longValue;
- } else if (resultPtr->typePtr == &tclDoubleType) {
- *ptr = resultPtr->internalRep.doubleValue;
- } else {
- result = Tcl_GetDoubleFromObj(interp, resultPtr, ptr);
- if (result != TCL_OK) {
- return result;
- }
+ switch (type) {
+ case TCL_NUMBER_NAN:
+#ifndef ACCEPT_NAN
+ result = Tcl_GetDoubleFromObj( interp, resultPtr, ptr );
+ break;
+#endif
+ case TCL_NUMBER_DOUBLE:
+ *ptr = *((CONST double *)internalPtr);
+ result = TCL_OK;
+ break;
+ default:
+ result = Tcl_GetDoubleFromObj( interp, resultPtr, ptr );
}
- Tcl_DecrRefCount(resultPtr); /* discard the result object */
}
+ Tcl_DecrRefCount(resultPtr); /* discard the result object */
return result;
}
@@ -5008,45 +4968,168 @@ Tcl_GetVersion(majorV, minorV, patchLevelV, type)
*/
static int
-ExprUnaryFunc(clientData, interp, objc, objv)
- ClientData clientData; /* Contains the address of a procedure that
- * takes one double argument and returns a
- * double result. */
+ExprCeilFunc(clientData, interp, objc, objv)
+ ClientData clientData; /* Ignored */
Tcl_Interp *interp; /* The interpreter in which to execute the
* function. */
int objc; /* Actual parameter count */
Tcl_Obj *CONST *objv; /* Actual parameter list */
{
- double d, dResult;
- Tcl_Obj* oResult;
+ int code;
+ double d;
+ mp_int big;
- double (*func)(double) = (double (*)(double)) clientData;
+ if (objc != 2) {
+ MathFuncWrongNumArgs(interp, 2, objc, objv);
+ return TCL_ERROR;
+ }
+ code = Tcl_GetDoubleFromObj(interp, objv[1], &d);
+#ifdef ACCEPT_NAN
+ if ((code != TCL_OK) && (objv[1]->typePtr == &tclDoubleType)) {
+ Tcl_SetObjResult(interp, objv[1]);
+ return TCL_OK;
+ }
+#endif
+ if (code != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (Tcl_GetBignumFromObj(NULL, objv[1], &big) == TCL_OK) {
+ Tcl_SetObjResult(interp, Tcl_NewDoubleObj(TclCeil(&big)));
+ mp_clear(&big);
+ } else {
+ Tcl_SetObjResult(interp, Tcl_NewDoubleObj(ceil(d)));
+ }
+ return TCL_OK;
+}
- /*
- * Convert the function's argument to a double if necessary.
- */
+static int
+ExprFloorFunc(clientData, interp, objc, objv)
+ ClientData clientData; /* Ignored */
+ Tcl_Interp *interp; /* The interpreter in which to execute the
+ * function. */
+ int objc; /* Actual parameter count */
+ Tcl_Obj *CONST *objv; /* Actual parameter list */
+{
+ int code;
+ double d;
+ mp_int big;
if (objc != 2) {
MathFuncWrongNumArgs(interp, 2, objc, objv);
- } else if (Tcl_GetDoubleFromObj(interp, objv[1], &d) == TCL_OK) {
+ return TCL_ERROR;
+ }
+ code = Tcl_GetDoubleFromObj(interp, objv[1], &d);
+#ifdef ACCEPT_NAN
+ if ((code != TCL_OK) && (objv[1]->typePtr == &tclDoubleType)) {
+ Tcl_SetObjResult(interp, objv[1]);
+ return TCL_OK;
+ }
+#endif
+ if (code != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (Tcl_GetBignumFromObj(NULL, objv[1], &big) == TCL_OK) {
+ Tcl_SetObjResult(interp, Tcl_NewDoubleObj(TclFloor(&big)));
+ mp_clear(&big);
+ } else {
+ Tcl_SetObjResult(interp, Tcl_NewDoubleObj(floor(d)));
+ }
+ return TCL_OK;
+}
- /*
- * Evaluate the function.
- */
+static int
+ExprSqrtFunc(clientData, interp, objc, objv)
+ ClientData clientData; /* Ignored */
+ Tcl_Interp *interp; /* The interpreter in which to execute the
+ * function. */
+ int objc; /* Actual parameter count */
+ Tcl_Obj *CONST *objv; /* Actual parameter list */
+{
+ int code;
+ double d;
+ mp_int big;
- dResult = (*func)(d);
- if ((errno != 0) || IS_NAN(dResult)) {
- if (errno != ERANGE || (dResult != 0.0 && !IS_INF(dResult))) {
- TclExprFloatError(interp, dResult);
- return TCL_ERROR;
- }
- }
- TclNewDoubleObj(oResult, dResult);
- Tcl_SetObjResult(interp, oResult);
+ if (objc != 2) {
+ MathFuncWrongNumArgs(interp, 2, objc, objv);
+ return TCL_ERROR;
+ }
+ code = Tcl_GetDoubleFromObj(interp, objv[1], &d);
+#ifdef ACCEPT_NAN
+ if ((code != TCL_OK) && (objv[1]->typePtr == &tclDoubleType)) {
+ Tcl_SetObjResult(interp, objv[1]);
return TCL_OK;
}
+#endif
+ if (code != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (d >= 0.0 && TclIsInfinite(d)
+ && Tcl_GetBignumFromObj(NULL, objv[1], &big) == TCL_OK) {
+ mp_int root;
+ mp_init(&root);
+ mp_sqrt(&big, &root);
+ mp_clear(&big);
+ Tcl_SetObjResult(interp, Tcl_NewDoubleObj(TclBignumToDouble(&root)));
+ mp_clear(&root);
+ } else {
+ Tcl_SetObjResult(interp, Tcl_NewDoubleObj(sqrt(d)));
+ }
+ return TCL_OK;
+}
- return TCL_ERROR;
+static int
+ExprUnaryFunc(clientData, interp, objc, objv)
+ ClientData clientData; /* Contains the address of a procedure that
+ * takes one double argument and returns a
+ * double result. */
+ Tcl_Interp *interp; /* The interpreter in which to execute the
+ * function. */
+ int objc; /* Actual parameter count */
+ Tcl_Obj *CONST *objv; /* Actual parameter list */
+{
+ int code;
+ double d;
+ double (*func)(double) = (double (*)(double)) clientData;
+
+ if (objc != 2) {
+ MathFuncWrongNumArgs(interp, 2, objc, objv);
+ return TCL_ERROR;
+ }
+ code = Tcl_GetDoubleFromObj(interp, objv[1], &d);
+#ifdef ACCEPT_NAN
+ if ((code != TCL_OK) && (objv[1]->typePtr == &tclDoubleType)) {
+ d = objv[1]->internalRep.doubleValue;
+ Tcl_ResetResult(interp);
+ code = TCL_OK;
+ }
+#endif
+ if (code != TCL_OK) {
+ return TCL_ERROR;
+ }
+ errno = 0;
+ return CheckDoubleResult(interp, (*func)(d));
+}
+
+static int
+CheckDoubleResult(interp, dResult)
+ Tcl_Interp *interp;
+ double dResult;
+{
+#ifndef ACCEPT_NAN
+ if (TclIsNaN(dResult)) {
+ TclExprFloatError(interp, dResult);
+ return TCL_ERROR;
+ }
+#endif
+ if ((errno == ERANGE) && ((dResult == 0.0) || TclIsInfinite(dResult))) {
+ /* When ERANGE signals under/overflow, just accept 0.0 or +/-Inf */
+ } else if (errno != 0) {
+ /* Report other errno values as errors */
+ TclExprFloatError(interp, dResult);
+ return TCL_ERROR;
+ }
+ Tcl_SetObjResult(interp, Tcl_NewDoubleObj(dResult));
+ return TCL_OK;
}
static int
@@ -5059,38 +5142,38 @@ ExprBinaryFunc(clientData, interp, objc, objv)
int objc; /* Actual parameter count */
Tcl_Obj *CONST *objv; /* Parameter vector */
{
- double d1, d2, dResult;
- Tcl_Obj* oResult;
-
+ int code;
+ double d1, d2;
double (*func)(double, double) = (double (*)(double, double)) clientData;
- /*
- * Convert the function's two arguments to doubles if necessary.
- */
-
if (objc != 3) {
MathFuncWrongNumArgs(interp, 3, objc, objv);
- } else if (Tcl_GetDoubleFromObj(interp, objv[1], &d1) == TCL_OK
- && Tcl_GetDoubleFromObj(interp, objv[2], &d2) == TCL_OK) {
- /*
- * Evaluate the function.
- */
-
- errno = 0;
- dResult = (*func)(d1, d2);
- if ((errno != 0) || IS_NAN(dResult)) {
- if (errno != ERANGE || (dResult != 0.0 && !IS_INF(dResult))) {
- TclExprFloatError(interp, dResult);
- return TCL_ERROR;
- }
- }
- TclNewDoubleObj(oResult, dResult);
- Tcl_SetObjResult(interp, oResult);
- return TCL_OK;
+ return TCL_ERROR;
+ }
+ code = Tcl_GetDoubleFromObj(interp, objv[1], &d1);
+#ifdef ACCEPT_NAN
+ if ((code != TCL_OK) && (objv[1]->typePtr == &tclDoubleType)) {
+ d1 = objv[1]->internalRep.doubleValue;
+ Tcl_ResetResult(interp);
+ code = TCL_OK;
}
-
- return TCL_ERROR;
-
+#endif
+ if (code != TCL_OK) {
+ return TCL_ERROR;
+ }
+ code = Tcl_GetDoubleFromObj(interp, objv[2], &d2);
+#ifdef ACCEPT_NAN
+ if ((code != TCL_OK) && (objv[2]->typePtr == &tclDoubleType)) {
+ d2 = objv[2]->internalRep.doubleValue;
+ Tcl_ResetResult(interp);
+ code = TCL_OK;
+ }
+#endif
+ if (code != TCL_OK) {
+ return TCL_ERROR;
+ }
+ errno = 0;
+ return CheckDoubleResult(interp, (*func)(d1, d2));
}
static int
@@ -5101,84 +5184,82 @@ ExprAbsFunc(clientData, interp, objc, objv)
int objc; /* Actual parameter count */
Tcl_Obj *CONST *objv; /* Parameter vector */
{
- register Tcl_Obj *valuePtr;
- long i, iResult;
- double d, dResult;
- Tcl_Obj* oResult;
+ ClientData ptr;
+ int type;
+ mp_int big;
if (objc != 2) {
MathFuncWrongNumArgs(interp, 2, objc, objv);
return TCL_ERROR;
}
- valuePtr = objv[1];
- if (VerifyExprObjType(interp, valuePtr) != TCL_OK) {
+ if (TclGetNumberFromObj(interp, objv[1], &ptr, &type) != TCL_OK) {
return TCL_ERROR;
}
- /*
- * Derive the absolute value according to the arg type.
- */
-
- if (valuePtr->typePtr == &tclIntType) {
- i = valuePtr->internalRep.longValue;
- if (i < 0) {
- iResult = -i;
- if (iResult < 0) {
-#ifdef TCL_WIDE_INT_IS_LONG
- 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
- /*
- * Special case: abs(MIN_INT) must promote to wide.
- */
- TclNewWideIntObj(oResult, -(Tcl_WideInt) i);
- Tcl_SetObjResult(interp, oResult);
- return TCL_OK;
-#endif
+ if (type == TCL_NUMBER_LONG) {
+ long l = *((CONST long int *)ptr);
+ if (l < (long)0) {
+ if (l == LONG_MIN) {
+ TclBNInitBignumFromLong(&big, l);
+ goto tooLarge;
}
+ Tcl_SetObjResult(interp, Tcl_NewLongObj(-l));
} else {
- iResult = i;
+ Tcl_SetObjResult(interp, objv[1]);
}
- TclNewLongObj(oResult, iResult);
- Tcl_SetObjResult(interp, oResult);
- } else if (valuePtr->typePtr == &tclWideIntType) {
- Tcl_WideInt wResult, w;
+ return TCL_OK;
+ }
- TclGetWide(w, valuePtr);
+ if (type == TCL_NUMBER_DOUBLE) {
+ double d = *((CONST double *)ptr);
+ if (d < 0.0) {
+ Tcl_SetObjResult(interp, Tcl_NewDoubleObj(-d));
+ } else {
+ Tcl_SetObjResult(interp, objv[1]);
+ }
+ return TCL_OK;
+ }
+
+#ifndef NO_WIDE_TYPE
+ if (type == TCL_NUMBER_WIDE) {
+ Tcl_WideInt w = *((CONST Tcl_WideInt *)ptr);
if (w < (Tcl_WideInt)0) {
- wResult = -w;
- if (wResult < 0) {
- 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;
+ if (w == LLONG_MIN) {
+ TclBNInitBignumFromWideInt(&big, w);
+ goto tooLarge;
}
+ Tcl_SetObjResult(interp, Tcl_NewWideIntObj(-w));
} else {
- wResult = w;
+ Tcl_SetObjResult(interp, objv[1]);
}
- TclNewWideIntObj(oResult, wResult);
- Tcl_SetObjResult(interp, oResult);
- } else {
- d = valuePtr->internalRep.doubleValue;
- if (d < 0.0) {
- dResult = -d;
+ return TCL_OK;
+ }
+#endif
+
+ if (type == TCL_NUMBER_BIG) {
+ /* TODO: const correctness ? */
+ if (mp_cmp_d((mp_int *)ptr, 0) == MP_LT) {
+ Tcl_GetBignumFromObj(NULL, objv[1], &big);
+ tooLarge:
+ mp_neg(&big, &big);
+ Tcl_SetObjResult(interp, Tcl_NewBignumObj(&big));
} else {
- dResult = d;
- }
- if (IS_NAN(dResult)) {
- TclExprFloatError(interp, dResult);
- return TCL_ERROR;
+ Tcl_SetObjResult(interp, objv[1]);
}
- TclNewDoubleObj(oResult, dResult);
- Tcl_SetObjResult(interp, oResult);
+ return TCL_OK;
}
- return TCL_OK;
+ if (type == TCL_NUMBER_NAN) {
+#ifdef ACCEPT_NAN
+ Tcl_SetObjResult(interp, objv[1]);
+ return TCL_OK;
+#else
+ double d;
+ Tcl_GetDoubleFromObj(interp, objv[1], &d);
+ return TCL_ERROR;
+#endif
+ }
}
static int
@@ -5210,8 +5291,9 @@ ExprDoubleFunc(clientData, interp, objc, objv)
int objc; /* Actual parameter count */
Tcl_Obj *CONST *objv; /* Actual parameter vector */
{
- Tcl_Obj* valuePtr;
double dResult;
+#if 0
+ Tcl_Obj* valuePtr;
Tcl_Obj* oResult;
/*
@@ -5231,6 +5313,68 @@ ExprDoubleFunc(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], &dResult) != TCL_OK) {
+#ifdef ACCEPT_NAN
+ if (objv[1]->typePtr == &tclDoubleType) {
+ Tcl_SetObjResult(interp, objv[1]);
+ return TCL_OK;
+ }
+#endif
+ return TCL_ERROR;
+ }
+ Tcl_SetObjResult(interp, Tcl_NewDoubleObj(dResult));
+ return TCL_OK;
+#endif
+}
+
+static int
+ExprEntierFunc(clientData, interp, objc, objv)
+ ClientData clientData; /* Ignored. */
+ Tcl_Interp *interp; /* The interpreter in which to execute the
+ * function. */
+ int objc; /* Actual parameter count */
+ Tcl_Obj *CONST *objv; /* Actual parameter vector */
+{
+ double d;
+ int type;
+ ClientData ptr;
+
+ if (objc != 2) {
+ MathFuncWrongNumArgs(interp, 2, objc, objv);
+ return TCL_ERROR;
+ }
+ if (TclGetNumberFromObj(interp, objv[1], &ptr, &type) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (type == TCL_NUMBER_DOUBLE) {
+ d = *((CONST double *)ptr);
+ if ((d >= (double)LONG_MAX) || (d <= (double)LONG_MIN)) {
+ mp_int big;
+ if (TclInitBignumFromDouble(interp, d, &big) != TCL_OK) {
+ /* Infinity */
+ return TCL_ERROR;
+ }
+ Tcl_SetObjResult(interp, Tcl_NewBignumObj(&big));
+ return TCL_OK;
+ } else {
+ long result = (long)d;
+ Tcl_SetObjResult(interp, Tcl_NewLongObj(result));
+ return TCL_OK;
+ }
+ }
+ if (type != TCL_NUMBER_NAN) {
+ /* All integers are already of integer type */
+ 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
@@ -5241,9 +5385,10 @@ ExprIntFunc(clientData, interp, objc, objv)
int objc; /* Actual parameter count */
Tcl_Obj *CONST *objv; /* Actual parameter vector */
{
- register Tcl_Obj *valuePtr;
long iResult;
- double d;
+ Tcl_Obj *objPtr;
+#if 0
+ register Tcl_Obj *valuePtr;
Tcl_Obj* oResult;
if (objc != 2) {
@@ -5282,6 +5427,24 @@ ExprIntFunc(clientData, interp, objc, objv)
}
}
return TCL_ERROR;
+#else
+ if (ExprEntierFunc(NULL, interp, objc, objv) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ objPtr = Tcl_GetObjResult(interp);
+ if (Tcl_GetLongFromObj(NULL, objPtr, &iResult) != TCL_OK) {
+ /* truncate the bignum; keep only bits in long range */
+ mp_int big;
+ 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;
+#endif
}
static int
@@ -5292,10 +5455,10 @@ ExprWideFunc(clientData, interp, objc, objv)
int objc; /* Actual parameter count */
Tcl_Obj *CONST *objv; /* Actual parameter vector */
{
-
- register Tcl_Obj *valuePtr;
Tcl_WideInt wResult;
- double d;
+ Tcl_Obj *objPtr;
+#if 0
+ register Tcl_Obj *valuePtr;
Tcl_Obj* oResult;
if (objc != 2) {
@@ -5334,6 +5497,24 @@ ExprWideFunc(clientData, interp, objc, objv)
}
}
return TCL_ERROR;
+#else
+ if (ExprEntierFunc(NULL, interp, objc, objv) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ 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;
+ 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;
+#endif
}
static int
@@ -5437,78 +5618,60 @@ ExprRoundFunc(clientData, interp, objc, objv)
int objc; /* Actual parameter count */
Tcl_Obj *CONST *objv; /* Parameter vector */
{
- Tcl_Obj *valuePtr, *resPtr;
- double d, i, f;
-
- /*
- * 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 (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.
- */
+ if (type == TCL_NUMBER_DOUBLE) {
+ double fractPart, intPart;
+ long max = LONG_MAX, min = LONG_MIN;
- d = valuePtr->internalRep.doubleValue;
- f = modf(d, &i);
- if (d < 0.0) {
- if (f <= -0.5) {
- i += -1.0;
+ fractPart = modf(*((CONST double *)ptr), &intPart);
+ if (fractPart <= -0.5) {
+ min++;
+ } else if (fractPart >= 0.5) {
+ max--;
}
- 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));
+ 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);
+ }
+ Tcl_SetObjResult(interp, Tcl_NewBignumObj(&big));
+ return TCL_OK;
} else {
- resPtr = Tcl_NewLongObj((long) i);
+ 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, resPtr);
- return TCL_OK;
-
- /*
- * Error return: result cannot be represented as an integer.
- */
-
- 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);
-
+ 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
@@ -5520,7 +5683,6 @@ ExprSrandFunc(clientData, interp, objc, objv)
Tcl_Obj *CONST *objv; /* Parameter vector */
{
Interp *iPtr = (Interp *) interp;
- Tcl_Obj *valuePtr;
long i = 0; /* Initialized to avoid compiler warning. */
/*
@@ -5531,18 +5693,9 @@ ExprSrandFunc(clientData, interp, objc, objv)
MathFuncWrongNumArgs(interp, 2, objc, objv);
return TCL_ERROR;
}
- valuePtr = objv[1];
- if (VerifyExprObjType(interp, valuePtr) != TCL_OK) {
- return TCL_ERROR;
- }
-
- if (Tcl_GetLongFromObj(NULL, valuePtr, &i) != TCL_OK) {
- /*
- * At this point, the only other possible type is double
- */
- Tcl_SetObjResult(interp, Tcl_NewStringObj(
- "can't use floating-point value as argument to srand", -1));
+ if (Tcl_GetLongFromObj(interp, objv[1], &i) != TCL_OK) {
+ /* TODO: more ::errorInfo here? or in caller? */
return TCL_ERROR;
}
@@ -5571,61 +5724,6 @@ ExprSrandFunc(clientData, interp, objc, objv)
/*
*----------------------------------------------------------------------
*
- * 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 of tclIntType, tclWideIntType or
- * 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 (IS_NUMERIC_TYPE(objPtr->typePtr)) {
- return TCL_OK;
- } else {
- int length, result = TCL_OK;
- char *s = Tcl_GetStringFromObj(objPtr, &length);
-
- if (TclLooksLikeInt(s, length)) {
- long i; /* Set but never used, needed in GET_WIDE_OR_INT */
- Tcl_WideInt w;
- GET_WIDE_OR_INT(result, objPtr, i, w);
- } else {
- double d;
- result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL, objPtr, &d);
- }
- if ((result != TCL_OK) && (interp != NULL)) {
- if (TclCheckBadOctal((Tcl_Interp *) NULL, s)) {
- Tcl_SetObjResult(interp, Tcl_NewStringObj(
- "argument to math function was an invalid octal number",
- -1));
- } else {
- Tcl_SetObjResult(interp, Tcl_NewStringObj(
- "argument to math function didn't have numeric value",
- -1));
- }
- }
- return result;
- }
-}
-
-/*
- *----------------------------------------------------------------------
- *
* MathFuncWrongNumArgs --
*
* Generate an error message when a math function presents the wrong
diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c
index a5124c2..18e7f01 100644
--- a/generic/tclCmdAH.c
+++ b/generic/tclCmdAH.c
@@ -10,12 +10,14 @@
* 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.68 2005/09/14 21:32:17 dgp Exp $
+ * RCS: @(#) $Id: tclCmdAH.c,v 1.69 2005/10/08 14:42:44 dgp Exp $
*/
#include "tclInt.h"
#include <locale.h>
+#define NEW_FORMAT 1
+
/*
* Prototypes for local procedures defined in this file:
*/
@@ -2245,6 +2247,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/tclCmdIL.c b/generic/tclCmdIL.c
index b98cf56..c7a9d83 100644
--- a/generic/tclCmdIL.c
+++ b/generic/tclCmdIL.c
@@ -16,7 +16,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclCmdIL.c,v 1.81 2005/09/14 21:32:17 dgp Exp $
+ * RCS: @(#) $Id: tclCmdIL.c,v 1.82 2005/10/08 14:42:44 dgp Exp $
*/
#include "tclInt.h"
@@ -301,16 +301,19 @@ Tcl_IncrObjCmd(dummy, interp, objc, objv)
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
+#if 0
long incrAmount = 1;
Tcl_WideInt wideIncrAmount;
- Tcl_Obj *newValuePtr;
int isWide = 0;
+#endif
+ Tcl_Obj *newValuePtr, *incrPtr;
if ((objc != 2) && (objc != 3)) {
Tcl_WrongNumArgs(interp, 1, objv, "varName ?increment?");
return TCL_ERROR;
}
+#if 0
/*
* Calculate the amount to increment by.
*/
@@ -357,6 +360,18 @@ Tcl_IncrObjCmd(dummy, interp, objc, objv)
newValuePtr = TclIncrVar2(interp, objv[1], (Tcl_Obj *) NULL,
incrAmount, TCL_LEAVE_ERR_MSG);
}
+#else
+ if (objc == 3) {
+ incrPtr = objv[2];
+ } else {
+ incrPtr = Tcl_NewIntObj(1);
+ }
+ Tcl_IncrRefCount(incrPtr);
+ newValuePtr = TclIncrObjVar2(interp, objv[1], NULL,
+ incrPtr, TCL_LEAVE_ERR_MSG);
+ Tcl_DecrRefCount(incrPtr);
+
+#endif
if (newValuePtr == NULL) {
return TCL_ERROR;
}
diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c
index b4a7d5a..a016124 100644
--- a/generic/tclCmdMZ.c
+++ b/generic/tclCmdMZ.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: tclCmdMZ.c,v 1.131 2005/09/15 16:40:02 dgp Exp $
+ * RCS: @(#) $Id: tclCmdMZ.c,v 1.132 2005/10/08 14:42:44 dgp Exp $
*/
#include "tclInt.h"
@@ -1530,52 +1530,20 @@ Tcl_StringObjCmd(dummy, interp, objc, objv)
case STR_IS_DOUBLE: {
char *stop;
+ /* TODO */
if ((objPtr->typePtr == &tclDoubleType) ||
- (objPtr->typePtr == &tclIntType)) {
- break;
- }
-
- /*
- * This is adapted from Tcl_GetDouble
- *
- * The danger in this function is that "12345678901234567890" is
- * an acceptable 'double', but will later be interp'd as an int by
- * something like [expr]. Therefore, we check to see if it looks
- * like an int, and if so we do a range check on it. If strtoul
- * gets to the end, we know we either received an acceptable int,
- * or over/underflow.
- */
-
- if (TclLooksLikeInt(string1, length1)) {
- errno = 0;
-#ifdef TCL_WIDE_INT_IS_LONG
- strtoul(string1, &stop, 0); /* INTL: Tcl source. */
-#else
- strtoull(string1, &stop, 0); /* INTL: Tcl source. */
+ (objPtr->typePtr == &tclIntType) ||
+#ifndef NO_WIDE_TYPE
+ (objPtr->typePtr == &tclWideIntType) ||
#endif
- if (stop == end) {
- if (errno == ERANGE) {
- result = 0;
- failat = -1;
- }
- break;
- }
+ (objPtr->typePtr == &tclBignumType)) {
+ break;
}
- errno = 0;
- TclStrToD(string1, (CONST char **) &stop); /* INTL: Tcl source. */
- if (stop == string1) {
- /*
- * In this case, nothing like a number was found.
- */
-
+ if (TclParseNumber( NULL, objPtr, NULL, NULL, -1,
+ (CONST char**) &stop, 0 ) != TCL_OK) {
result = 0;
failat = 0;
} else {
- /*
- * Assume we sucked up one char per byte and then we go onto
- * SPACE, since we are allowed trailing whitespace.
- */
-
failat = stop - string1;
string1 = stop;
chcomp = Tcl_UniCharIsSpace;
diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c
index 4f962ca..c340846 100644
--- a/generic/tclCompCmds.c
+++ b/generic/tclCompCmds.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: tclCompCmds.c,v 1.77 2005/07/21 21:49:00 dkf Exp $
+ * RCS: @(#) $Id: tclCompCmds.c,v 1.78 2005/10/08 14:42:45 dgp Exp $
*/
#include "tclInt.h"
@@ -611,6 +611,7 @@ TclCompileDictCmd(interp, parsePtr, envPtr)
word = incrTokenPtr[1].start;
numBytes = incrTokenPtr[1].size;
+#if 0
/*
* Note there is a danger that modifying the string could have
* undesirable side effects. In this case, TclLooksLikeInt has no
@@ -620,6 +621,7 @@ TclCompileDictCmd(interp, parsePtr, envPtr)
if (!TclLooksLikeInt(word, numBytes)) {
return TCL_ERROR;
}
+#endif
/*
* Now try to really parse the number.
@@ -1959,7 +1961,7 @@ TclCompileIncrCmd(interp, parsePtr, envPtr)
if (incrTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
CONST char *word = incrTokenPtr[1].start;
int numBytes = incrTokenPtr[1].size;
-
+#if 0
/*
* Note there is a danger that modifying the string could have
* undesirable side effects. In this case, TclLooksLikeInt has
@@ -1967,6 +1969,7 @@ TclCompileIncrCmd(interp, parsePtr, envPtr)
*/
if (TclLooksLikeInt(word, numBytes)) {
+#endif
int code;
Tcl_Obj *intObj = Tcl_NewStringObj(word, numBytes);
Tcl_IncrRefCount(intObj);
@@ -1976,7 +1979,9 @@ TclCompileIncrCmd(interp, parsePtr, envPtr)
&& (-127 <= immValue) && (immValue <= 127)) {
haveImmValue = 1;
}
+#if 0
}
+#endif
if (!haveImmValue) {
PushLiteral(envPtr, word, numBytes);
}
@@ -2280,8 +2285,11 @@ TclCompileLindexCmd(interp, parsePtr, envPtr)
varTokenPtr = TokenAfter(parsePtr->tokenPtr);
- if ((numWords == 3) && (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) &&
- TclLooksLikeInt(varTokenPtr[1].start, varTokenPtr[1].size)) {
+ if ((numWords == 3) && (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD)
+#if 0
+ && TclLooksLikeInt(varTokenPtr[1].start, varTokenPtr[1].size)
+#endif
+ ) {
Tcl_Obj *tmpObj;
int idx, result;
diff --git a/generic/tclCompExpr.c b/generic/tclCompExpr.c
index e102d28..7741d1d 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.28 2005/08/03 22:25:11 dgp Exp $
+ * RCS: @(#) $Id: tclCompExpr.c,v 1.29 2005/10/08 14:42:45 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/tclDecls.h b/generic/tclDecls.h
index 4528521..f01f3ca 100644
--- a/generic/tclDecls.h
+++ b/generic/tclDecls.h
@@ -8,7 +8,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclDecls.h,v 1.116 2005/09/13 21:23:51 dgp Exp $
+ * RCS: @(#) $Id: tclDecls.h,v 1.117 2005/10/08 14:42:45 dgp Exp $
*/
#ifndef _TCLDECLS
@@ -3484,39 +3484,46 @@ EXTERN void Tcl_SetBignumObj _ANSI_ARGS_((Tcl_Obj* obj,
EXTERN int Tcl_GetBignumFromObj _ANSI_ARGS_((Tcl_Interp* interp,
Tcl_Obj* obj, mp_int* value));
#endif
+#ifndef Tcl_GetBignumAndClearObj_TCL_DECLARED
+#define Tcl_GetBignumAndClearObj_TCL_DECLARED
+/* 559 */
+EXTERN int Tcl_GetBignumAndClearObj _ANSI_ARGS_((
+ Tcl_Interp* interp, Tcl_Obj* obj,
+ mp_int* value));
+#endif
#ifndef Tcl_TruncateChannel_TCL_DECLARED
#define Tcl_TruncateChannel_TCL_DECLARED
-/* 559 */
+/* 560 */
EXTERN int Tcl_TruncateChannel _ANSI_ARGS_((Tcl_Channel chan,
Tcl_WideInt length));
#endif
#ifndef Tcl_ChannelTruncateProc_TCL_DECLARED
#define Tcl_ChannelTruncateProc_TCL_DECLARED
-/* 560 */
+/* 561 */
EXTERN Tcl_DriverTruncateProc * Tcl_ChannelTruncateProc _ANSI_ARGS_((
Tcl_ChannelType * chanTypePtr));
#endif
#ifndef Tcl_SetChannelErrorInterp_TCL_DECLARED
#define Tcl_SetChannelErrorInterp_TCL_DECLARED
-/* 561 */
+/* 562 */
EXTERN void Tcl_SetChannelErrorInterp _ANSI_ARGS_((
Tcl_Interp* interp, Tcl_Obj* msg));
#endif
#ifndef Tcl_GetChannelErrorInterp_TCL_DECLARED
#define Tcl_GetChannelErrorInterp_TCL_DECLARED
-/* 562 */
+/* 563 */
EXTERN void Tcl_GetChannelErrorInterp _ANSI_ARGS_((
Tcl_Interp* interp, Tcl_Obj** msg));
#endif
#ifndef Tcl_SetChannelError_TCL_DECLARED
#define Tcl_SetChannelError_TCL_DECLARED
-/* 563 */
+/* 564 */
EXTERN void Tcl_SetChannelError _ANSI_ARGS_((Tcl_Channel chan,
Tcl_Obj* msg));
#endif
#ifndef Tcl_GetChannelError_TCL_DECLARED
#define Tcl_GetChannelError_TCL_DECLARED
-/* 564 */
+/* 565 */
EXTERN void Tcl_GetChannelError _ANSI_ARGS_((Tcl_Channel chan,
Tcl_Obj** msg));
#endif
@@ -4120,12 +4127,13 @@ typedef struct TclStubs {
Tcl_Obj* (*tcl_DbNewBignumObj) _ANSI_ARGS_((mp_int* value, CONST char* file, int line)); /* 556 */
void (*tcl_SetBignumObj) _ANSI_ARGS_((Tcl_Obj* obj, mp_int* value)); /* 557 */
int (*tcl_GetBignumFromObj) _ANSI_ARGS_((Tcl_Interp* interp, Tcl_Obj* obj, mp_int* value)); /* 558 */
- int (*tcl_TruncateChannel) _ANSI_ARGS_((Tcl_Channel chan, Tcl_WideInt length)); /* 559 */
- Tcl_DriverTruncateProc * (*tcl_ChannelTruncateProc) _ANSI_ARGS_((Tcl_ChannelType * chanTypePtr)); /* 560 */
- void (*tcl_SetChannelErrorInterp) _ANSI_ARGS_((Tcl_Interp* interp, Tcl_Obj* msg)); /* 561 */
- void (*tcl_GetChannelErrorInterp) _ANSI_ARGS_((Tcl_Interp* interp, Tcl_Obj** msg)); /* 562 */
- void (*tcl_SetChannelError) _ANSI_ARGS_((Tcl_Channel chan, Tcl_Obj* msg)); /* 563 */
- void (*tcl_GetChannelError) _ANSI_ARGS_((Tcl_Channel chan, Tcl_Obj** msg)); /* 564 */
+ int (*tcl_GetBignumAndClearObj) _ANSI_ARGS_((Tcl_Interp* interp, Tcl_Obj* obj, mp_int* value)); /* 559 */
+ int (*tcl_TruncateChannel) _ANSI_ARGS_((Tcl_Channel chan, Tcl_WideInt length)); /* 560 */
+ Tcl_DriverTruncateProc * (*tcl_ChannelTruncateProc) _ANSI_ARGS_((Tcl_ChannelType * chanTypePtr)); /* 561 */
+ void (*tcl_SetChannelErrorInterp) _ANSI_ARGS_((Tcl_Interp* interp, Tcl_Obj* msg)); /* 562 */
+ void (*tcl_GetChannelErrorInterp) _ANSI_ARGS_((Tcl_Interp* interp, Tcl_Obj** msg)); /* 563 */
+ void (*tcl_SetChannelError) _ANSI_ARGS_((Tcl_Channel chan, Tcl_Obj* msg)); /* 564 */
+ void (*tcl_GetChannelError) _ANSI_ARGS_((Tcl_Channel chan, Tcl_Obj** msg)); /* 565 */
} TclStubs;
#ifdef __cplusplus
@@ -6402,29 +6410,33 @@ extern TclStubs *tclStubsPtr;
#define Tcl_GetBignumFromObj \
(tclStubsPtr->tcl_GetBignumFromObj) /* 558 */
#endif
+#ifndef Tcl_GetBignumAndClearObj
+#define Tcl_GetBignumAndClearObj \
+ (tclStubsPtr->tcl_GetBignumAndClearObj) /* 559 */
+#endif
#ifndef Tcl_TruncateChannel
#define Tcl_TruncateChannel \
- (tclStubsPtr->tcl_TruncateChannel) /* 559 */
+ (tclStubsPtr->tcl_TruncateChannel) /* 560 */
#endif
#ifndef Tcl_ChannelTruncateProc
#define Tcl_ChannelTruncateProc \
- (tclStubsPtr->tcl_ChannelTruncateProc) /* 560 */
+ (tclStubsPtr->tcl_ChannelTruncateProc) /* 561 */
#endif
#ifndef Tcl_SetChannelErrorInterp
#define Tcl_SetChannelErrorInterp \
- (tclStubsPtr->tcl_SetChannelErrorInterp) /* 561 */
+ (tclStubsPtr->tcl_SetChannelErrorInterp) /* 562 */
#endif
#ifndef Tcl_GetChannelErrorInterp
#define Tcl_GetChannelErrorInterp \
- (tclStubsPtr->tcl_GetChannelErrorInterp) /* 562 */
+ (tclStubsPtr->tcl_GetChannelErrorInterp) /* 563 */
#endif
#ifndef Tcl_SetChannelError
#define Tcl_SetChannelError \
- (tclStubsPtr->tcl_SetChannelError) /* 563 */
+ (tclStubsPtr->tcl_SetChannelError) /* 564 */
#endif
#ifndef Tcl_GetChannelError
#define Tcl_GetChannelError \
- (tclStubsPtr->tcl_GetChannelError) /* 564 */
+ (tclStubsPtr->tcl_GetChannelError) /* 565 */
#endif
#endif /* defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) */
diff --git a/generic/tclDictObj.c b/generic/tclDictObj.c
index 196455e..aa88d69 100644
--- a/generic/tclDictObj.c
+++ b/generic/tclDictObj.c
@@ -9,10 +9,11 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclDictObj.c,v 1.35 2005/09/16 01:40:15 dgp Exp $
+ * RCS: @(#) $Id: tclDictObj.c,v 1.36 2005/10/08 14:42:45 dgp Exp $
*/
#include "tclInt.h"
+#include "tommath.h"
/*
* Forward declaration.
@@ -1873,17 +1874,23 @@ DictIncrCmd(interp, objc, objv)
int objc;
Tcl_Obj *CONST *objv;
{
- Tcl_Obj *dictPtr, *valuePtr, *resultPtr;
+#if 0
+ Tcl_Obj *dictPtr, *resultPtr;
int result, isWide = 0;
long incrValue = 1;
Tcl_WideInt wideIncrValue = 0;
int allocatedDict = 0;
+#else
+ int code = TCL_OK;
+ Tcl_Obj *dictPtr, *valuePtr = NULL;
+#endif
if (objc < 4 || objc > 5) {
Tcl_WrongNumArgs(interp, 2, objv, "varName key ?increment?");
return TCL_ERROR;
}
+#if 0
if (objc == 5) {
if (objv[4]->typePtr == &tclIntType) {
incrValue = objv[4]->internalRep.longValue;
@@ -2040,6 +2047,67 @@ DictIncrCmd(interp, objc, objv)
}
Tcl_SetObjResult(interp, resultPtr);
return TCL_OK;
+#else
+ dictPtr = Tcl_ObjGetVar2(interp, objv[2], NULL, 0);
+ if (dictPtr == NULL) {
+ /* Variable didn't yet exist. Create new dictionary value */
+ dictPtr = Tcl_NewDictObj();
+ } else if (Tcl_DictObjGet(interp, dictPtr, objv[3], &valuePtr) != TCL_OK) {
+ /* Variable contents are not a dict, report error */
+ return TCL_ERROR;
+ }
+ if (Tcl_IsShared(dictPtr)) {
+ /* A little internals surgery to avoid copying a string rep
+ * that will soon be no good */
+ char *saved = dictPtr->bytes;
+ dictPtr->bytes = NULL;
+ dictPtr = Tcl_DuplicateObj(dictPtr);
+ dictPtr->bytes = saved;
+ }
+ if (valuePtr == NULL) {
+ /* Key not in dictionary. Create new key with increment as value */
+ if (objc == 5) {
+ /* Verify increment is an integer */
+ mp_int increment;
+ code = Tcl_GetBignumFromObj(interp, objv[4], &increment);
+ if (code != TCL_OK) {
+ Tcl_AddErrorInfo(interp, "\n (reading increment)");
+ } else {
+ Tcl_DictObjPut(interp, dictPtr, objv[3], objv[4]);
+ }
+ } else {
+ Tcl_DictObjPut(interp, dictPtr, objv[3], Tcl_NewIntObj(1));
+ }
+ } else {
+ /* Key in dictionary. Increment its value with minimum dup. */
+ if (Tcl_IsShared(valuePtr)) {
+ valuePtr = Tcl_DuplicateObj(valuePtr);
+ Tcl_DictObjPut(interp, dictPtr, objv[3], valuePtr);
+ }
+ if (objc == 5) {
+ code = TclIncrObj(interp, valuePtr, objv[4]);
+ } else {
+ Tcl_Obj *incrPtr = Tcl_NewIntObj(1);
+ Tcl_IncrRefCount(incrPtr);
+ code = TclIncrObj(interp, valuePtr, incrPtr);
+ Tcl_DecrRefCount(incrPtr);
+ }
+ }
+ Tcl_IncrRefCount(dictPtr);
+ if (code == TCL_OK) {
+ Tcl_InvalidateStringRep(dictPtr);
+ valuePtr = Tcl_ObjSetVar2(interp, objv[2], NULL,
+ dictPtr, TCL_LEAVE_ERR_MSG);
+ if (valuePtr == NULL) {
+ code = TCL_ERROR;
+ }
+ }
+ Tcl_DecrRefCount(dictPtr);
+ if (code == TCL_OK) {
+ Tcl_SetObjResult(interp, valuePtr);
+ }
+ return code;
+#endif
}
/*
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index c7502f0..33e5ae2 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -12,11 +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: tclExecute.c,v 1.201 2005/09/15 16:40:02 dgp Exp $
+ * RCS: @(#) $Id: tclExecute.c,v 1.202 2005/10/08 14:42:45 dgp Exp $
*/
#include "tclInt.h"
#include "tclCompile.h"
+#include "tommath.h"
#include <math.h>
#include <float.h>
@@ -48,26 +49,13 @@
# define NO_ERRNO_H
#endif /* !TCL_GENERIC_ONLY */
+#if 0
#ifdef NO_ERRNO_H
int errno;
# define EDOM 33
# define ERANGE 34
#endif
-
-/*
- * Need DBL_MAX for IS_INF() macro...
- */
-#ifndef DBL_MAX
-# ifdef MAXDOUBLE
-# define DBL_MAX MAXDOUBLE
-# else /* !MAXDOUBLE */
-/*
- * This value is from the Solaris headers, but doubles seem to be the same
- * size everywhere. Long doubles aren't, but we don't use those.
- */
-# 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,20 +129,6 @@ long tclObjsShared[TCL_MAX_SHARED_OBJ_STATS] = { 0, 0, 0, 0, 0 };
#endif /* TCL_COMPILE_STATS */
/*
- * 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.
- */
-
-#ifdef _MSC_VER
-#define IS_NAN(f) (_isnan((f)))
-#define IS_INF(f) ( ! (_finite((f))))
-#else
-#define IS_NAN(f) ((f) != (f))
-#define IS_INF(f) ( (f) > DBL_MAX || (f) < -DBL_MAX )
-#endif
-
-/*
* The new macro for ending an instruction; note that a reasonable C-optimiser
* will resolve all branches at compile time. (result) is always a constant;
* the macro NEXT_INST_F handles constant (nCleanup), NEXT_INST_V is resolved
@@ -286,6 +260,7 @@ long tclObjsShared[TCL_MAX_SHARED_OBJ_STATS] = { 0, 0, 0, 0, 0 };
# define O2S(objPtr)
#endif /* TCL_COMPILE_DEBUG */
+#if 0
/*
* Macro to read a string containing either a wide or an int and decide which
* it is while decoding it at the same time. This enforces the policy that
@@ -295,6 +270,7 @@ long tclObjsShared[TCL_MAX_SHARED_OBJ_STATS] = { 0, 0, 0, 0, 0 };
*
* GET_WIDE_OR_INT is the same as REQUIRE_WIDE_OR_INT except it never
* generates an error message.
+ *
*/
#define REQUIRE_WIDE_OR_INT(resultVar, objPtr, longVar, wideVar) \
(resultVar) = Tcl_GetWideIntFromObj(interp, (objPtr), &(wideVar)); \
@@ -313,15 +289,17 @@ long tclObjsShared[TCL_MAX_SHARED_OBJ_STATS] = { 0, 0, 0, 0, 0 };
(objPtr)->internalRep.longValue = (longVar) \
= Tcl_WideAsLong(wideVar); \
}
+#endif
/*
* Combined with REQUIRE_WIDE_OR_INT, this gets a long value from an obj.
*/
+#if 0
#define FORCE_LONG(objPtr, longVar, wideVar) \
if ((objPtr)->typePtr == &tclWideIntType) { \
(longVar) = Tcl_WideAsLong(wideVar); \
}
#define IS_INTEGER_TYPE(typePtr) \
- ((typePtr) == &tclIntType || (typePtr) == &tclWideIntType)
+ ((typePtr) == &tclIntType || (typePtr) == &tclWideIntType || (typePtr) == &tclBignumType)
#define IS_NUMERIC_TYPE(typePtr) \
(IS_INTEGER_TYPE(typePtr) || (typePtr) == &tclDoubleType)
@@ -351,6 +329,89 @@ long tclObjsShared[TCL_MAX_SHARED_OBJ_STATS] = { 0, 0, 0, 0, 0 };
(doubleVar) = (objPtr)->internalRep.doubleValue; \
}
#endif /* TCL_WIDE_INT_IS_LONG */
+#endif
+
+/*
+ * Macro used in this file to save a function call for common uses of
+ * TclGetNumberFromObj(). The ANSI C "prototype" is:
+ *
+ * MODULE_SCOPE int GetNumberFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
+ * ClientData *ptrPtr, int *tPtr);
+ */
+
+#ifdef TCL_WIDE_INT_IS_LONG
+
+#define GetNumberFromObj(interp, objPtr, ptrPtr, tPtr) \
+ (((objPtr)->typePtr == &tclIntType) \
+ ? (*(tPtr) = TCL_NUMBER_LONG, \
+ *(ptrPtr) = (ClientData) \
+ (&((objPtr)->internalRep.longValue)), TCL_OK) : \
+ ((objPtr)->typePtr == &tclDoubleType) \
+ ? (((TclIsNaN((objPtr)->internalRep.doubleValue)) \
+ ? (*(tPtr) = TCL_NUMBER_NAN) \
+ : (*(tPtr) = TCL_NUMBER_DOUBLE)), \
+ *(ptrPtr) = (ClientData) \
+ (&((objPtr)->internalRep.doubleValue)), TCL_OK) : \
+ TclGetNumberFromObj((interp), (objPtr), (ptrPtr), (tPtr)))
+
+#else
+
+#define GetNumberFromObj(interp, objPtr, ptrPtr, tPtr) \
+ (((objPtr)->typePtr == &tclIntType) \
+ ? (*(tPtr) = TCL_NUMBER_LONG, \
+ *(ptrPtr) = (ClientData) \
+ (&((objPtr)->internalRep.longValue)), TCL_OK) : \
+ ((objPtr)->typePtr == &tclWideIntType) \
+ ? (*(tPtr) = TCL_NUMBER_WIDE, \
+ *(ptrPtr) = (ClientData) \
+ (&((objPtr)->internalRep.wideValue)), TCL_OK) : \
+ ((objPtr)->typePtr == &tclDoubleType) \
+ ? (((TclIsNaN((objPtr)->internalRep.doubleValue)) \
+ ? (*(tPtr) = TCL_NUMBER_NAN) \
+ : (*(tPtr) = TCL_NUMBER_DOUBLE)), \
+ *(ptrPtr) = (ClientData) \
+ (&((objPtr)->internalRep.doubleValue)), TCL_OK) : \
+ TclGetNumberFromObj((interp), (objPtr), (ptrPtr), (tPtr)))
+
+#endif
+
+/*
+ * Macro used in this file to save a function call for common uses of
+ * Tcl_GetBooleanFromObj(). The ANSI C "prototype" is:
+ *
+ * MODULE_SCOPE int TclGetBooleanFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
+ * int *boolPtr);
+ */
+
+#define TclGetBooleanFromObj(interp, objPtr, boolPtr) \
+ ((((objPtr)->typePtr == &tclIntType) \
+ || ((objPtr)->typePtr == &tclIntType)) \
+ ? (*(boolPtr) = ((objPtr)->internalRep.longValue!=0), TCL_OK) \
+ : Tcl_GetBooleanFromObj((interp), (objPtr), (boolPtr)))
+
+/*
+ * Macro used in this file to save a function call for common uses of
+ * Tcl_GetWideIntFromObj(). The ANSI C "prototype" is:
+ *
+ * MODULE_SCOPE int TclGetWideIntFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
+ * Tcl_WideInt *wideIntPtr);
+ */
+
+#ifdef TCL_WIDE_INT_IS_LONG
+#define TclGetWideIntFromObj(interp, objPtr, wideIntPtr) \
+ (((objPtr)->typePtr == &tclIntType) \
+ ? (*(wideIntPtr) = (Tcl_WideInt) \
+ ((objPtr)->internalRep.longValue), TCL_OK) : \
+ Tcl_GetWideIntFromObj((interp), (objPtr), (wideIntPtr)))
+#else
+#define TclGetWideIntFromObj(interp, objPtr, wideIntPtr) \
+ (((objPtr)->typePtr == &tclWideIntType) \
+ ? (*(wideIntPtr) = (objPtr)->internalRep.wideValue, TCL_OK) : \
+ ((objPtr)->typePtr == &tclIntType) \
+ ? (*(wideIntPtr) = (Tcl_WideInt) \
+ ((objPtr)->internalRep.longValue), TCL_OK) : \
+ Tcl_GetWideIntFromObj((interp), (objPtr), (wideIntPtr)))
+#endif
static Tcl_ObjType dictIteratorType = {
"dictIterator",
@@ -389,10 +450,12 @@ static void ValidatePcAndStackTop _ANSI_ARGS_((
int stackTop, int stackLowerBound,
int checkStack));
#endif /* TCL_COMPILE_DEBUG */
+#if 0
static Tcl_WideInt ExponWide _ANSI_ARGS_((Tcl_WideInt w, Tcl_WideInt w2,
int *errExpon));
static long ExponLong _ANSI_ARGS_((long i, long i2,
int *errExpon));
+#endif
/*
@@ -481,9 +544,9 @@ TclCreateExecEnv(interp)
eePtr->tosPtr = stackPtr - 1;
eePtr->endPtr = stackPtr + (TCL_STACK_INITIAL_SIZE - 2);
- TclNewIntObj(eePtr->constants[0], 0);
+ TclNewBooleanObj(eePtr->constants[0], 0);
Tcl_IncrRefCount(eePtr->constants[0]);
- TclNewIntObj(eePtr->constants[1], 1);
+ TclNewBooleanObj(eePtr->constants[1], 1);
Tcl_IncrRefCount(eePtr->constants[1]);
Tcl_MutexLock(&execMutex);
@@ -753,24 +816,24 @@ Tcl_ExprObj(interp, objPtr, resultPtrPtr)
string = Tcl_GetStringFromObj(objPtr, &length);
if (length == 1) {
if (*string == '0') {
- TclNewLongObj(resultPtr, 0);
+ TclNewBooleanObj(resultPtr, 0);
Tcl_IncrRefCount(resultPtr);
*resultPtrPtr = resultPtr;
return TCL_OK;
} else if (*string == '1') {
- TclNewLongObj(resultPtr, 1);
+ TclNewBooleanObj(resultPtr, 1);
Tcl_IncrRefCount(resultPtr);
*resultPtrPtr = resultPtr;
return TCL_OK;
}
} else if ((length == 2) && (*string == '!')) {
if (*(string+1) == '0') {
- TclNewLongObj(resultPtr, 1);
+ TclNewBooleanObj(resultPtr, 1);
Tcl_IncrRefCount(resultPtr);
*resultPtrPtr = resultPtr;
return TCL_OK;
} else if (*(string+1) == '1') {
- TclNewLongObj(resultPtr, 0);
+ TclNewBooleanObj(resultPtr, 0);
Tcl_IncrRefCount(resultPtr);
*resultPtrPtr = resultPtr;
return TCL_OK;
@@ -1031,6 +1094,79 @@ TclCompEvalObj(interp, objPtr)
/*
*----------------------------------------------------------------------
*
+ * TclIncrObj --
+ *
+ * Increment an integeral value in a Tcl_Obj by an integeral value
+ * held in another Tcl_Obj. Caller is responsible for making sure
+ * we can update the first object.
+ *
+ * Results:
+ * TCL_ERROR if either object is non-integer, and TCL_OK otherwise. On
+ * error, an error message is left in the interpreter (if it is not NULL,
+ * of course).
+ *
+ * Side effects:
+ * valuePtr gets the new incrmented value.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclIncrObj(interp, valuePtr, incrPtr)
+ Tcl_Interp *interp;
+ Tcl_Obj *valuePtr;
+ Tcl_Obj *incrPtr;
+{
+ ClientData ptr1, ptr2;
+ int type1, type2;
+ mp_int value, incr;
+
+ if (Tcl_IsShared(valuePtr)) {
+ Tcl_Panic("shared object passed to TclIncrObj");
+ }
+
+ if ((GetNumberFromObj(NULL, valuePtr, &ptr1, &type1) != TCL_OK)
+ || (type1 == TCL_NUMBER_DOUBLE) || (type1 == TCL_NUMBER_NAN)) {
+ /* Produce error message (reparse?!) */
+ return Tcl_GetIntFromObj(interp, valuePtr, &type1);
+ }
+ if ((GetNumberFromObj(NULL, incrPtr, &ptr2, &type2) != TCL_OK)
+ || (type1 == TCL_NUMBER_DOUBLE) || (type1 == TCL_NUMBER_NAN)) {
+ /* Produce error message (reparse?!) */
+ Tcl_GetIntFromObj(interp, incrPtr, &type1);
+ Tcl_AddErrorInfo(interp, "\n (reading increment)");
+ return TCL_ERROR;
+ }
+ do {if ((type1 != TCL_NUMBER_BIG) && (type2 != TCL_NUMBER_BIG)) {
+ Tcl_WideInt w1, w2, sum;
+ TclGetWideIntFromObj(NULL, valuePtr, &w1);
+ TclGetWideIntFromObj(NULL, incrPtr, &w2);
+ sum = w1 + w2;
+#ifndef NO_WIDE_TYPE
+ if ((type1 == TCL_NUMBER_WIDE) || (type2 == TCL_NUMBER_WIDE))
+#endif
+ {
+ /* Check for overflow */
+ if (((w1 < 0) && (w2 < 0) && (sum > 0))
+ || ((w1 > 0) && (w2 > 0) && (sum < 0))) {
+ break;
+ }
+ }
+ Tcl_SetWideIntObj(valuePtr, sum);
+ return TCL_OK;
+ }} while (0);
+
+ Tcl_GetBignumAndClearObj(interp, valuePtr, &value);
+ Tcl_GetBignumFromObj(interp, incrPtr, &incr);
+ mp_add(&value, &incr, &value);
+ mp_clear(&incr);
+ Tcl_SetBignumObj(valuePtr, &value);
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* TclExecuteByteCode --
*
* This procedure executes the instructions of a ByteCode structure. It
@@ -2215,11 +2351,16 @@ TclExecuteByteCode(interp, codePtr)
* common execution code.
*/
+/*TODO: Consider more untangling here; merge with LOAD and STORE ? */
+
{
- Tcl_Obj *objPtr;
- int opnd, pcAdjustment, isWide;
- long i;
+ Tcl_Obj *objPtr, *incrPtr;
+ int opnd, pcAdjustment;
+#if 0
+ int isWide;
Tcl_WideInt w;
+#endif
+ long i;
char *part1, *part2;
Var *varPtr, *arrayPtr;
@@ -2229,6 +2370,7 @@ TclExecuteByteCode(interp, codePtr)
case INST_INCR_SCALAR_STK:
case INST_INCR_STK:
opnd = TclGetUInt1AtPtr(pc+1);
+#if 0
objPtr = *tosPtr;
if (objPtr->typePtr == &tclIntType) {
i = objPtr->internalRep.longValue;
@@ -2250,6 +2392,10 @@ TclExecuteByteCode(interp, codePtr)
}
tosPtr--;
TclDecrRefCount(objPtr);
+#else
+ incrPtr = *tosPtr;
+ tosPtr--;
+#endif
switch (*pc) {
case INST_INCR_SCALAR1:
pcAdjustment = 2;
@@ -2266,7 +2412,12 @@ TclExecuteByteCode(interp, codePtr)
case INST_INCR_SCALAR_STK_IMM:
case INST_INCR_STK_IMM:
i = TclGetInt1AtPtr(pc+1);
+#if 0
isWide = 0;
+#else
+ incrPtr = Tcl_NewIntObj(i);
+ Tcl_IncrRefCount(incrPtr);
+#endif
pcAdjustment = 2;
doIncrStk:
@@ -2290,6 +2441,7 @@ TclExecuteByteCode(interp, codePtr)
"\n (reading value of variable to increment)", -1);
TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));
result = TCL_ERROR;
+ Tcl_DecrRefCount(incrPtr);
goto checkForCatch;
}
cleanup = ((part2 == NULL)? 1 : 2);
@@ -2298,7 +2450,12 @@ TclExecuteByteCode(interp, codePtr)
case INST_INCR_ARRAY1_IMM:
opnd = TclGetUInt1AtPtr(pc+1);
i = TclGetInt1AtPtr(pc+2);
+#if 0
isWide = 0;
+#else
+ incrPtr = Tcl_NewIntObj(i);
+ Tcl_IncrRefCount(incrPtr);
+#endif
pcAdjustment = 3;
doIncrArray:
@@ -2314,6 +2471,7 @@ TclExecuteByteCode(interp, codePtr)
if (varPtr == NULL) {
TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));
result = TCL_ERROR;
+ Tcl_DecrRefCount(incrPtr);
goto checkForCatch;
}
cleanup = 1;
@@ -2322,7 +2480,12 @@ TclExecuteByteCode(interp, codePtr)
case INST_INCR_SCALAR1_IMM:
opnd = TclGetUInt1AtPtr(pc+1);
i = TclGetInt1AtPtr(pc+2);
+#if 0
isWide = 0;
+#else
+ incrPtr = Tcl_NewIntObj(i);
+ Tcl_IncrRefCount(incrPtr);
+#endif
pcAdjustment = 3;
doIncrScalar:
@@ -2337,6 +2500,7 @@ TclExecuteByteCode(interp, codePtr)
TRACE(("%u %ld => ", opnd, i));
doIncrVar:
+#if 0
objPtr = varPtr->value.objPtr;
if (TclIsVarDirectReadable(varPtr)
&& ((arrayPtr == NULL) || TclIsVarUntraced(arrayPtr))) {
@@ -2385,12 +2549,22 @@ TclExecuteByteCode(interp, codePtr)
part2, i, TCL_LEAVE_ERR_MSG);
}
CACHE_STACK_INFO();
+#else
+ /* TODO: Restore no trace optimization */
+ DECACHE_STACK_INFO();
+ objResultPtr = TclPtrIncrObjVar(interp, varPtr, arrayPtr, part1, part2,
+ incrPtr, TCL_LEAVE_ERR_MSG);
+ CACHE_STACK_INFO();
+ Tcl_DecrRefCount(incrPtr);
+#endif
if (objResultPtr == NULL) {
TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));
result = TCL_ERROR;
goto checkForCatch;
}
+#if 0
doneIncr:
+#endif
TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
#ifndef TCL_COMPILE_DEBUG
if (*(pc+pcAdjustment) == INST_POP) {
@@ -2430,6 +2604,8 @@ TclExecuteByteCode(interp, codePtr)
int b;
Tcl_Obj *valuePtr;
+/* TODO: consider rewrite so we don't compute the offset we're
+ * not going to take. */
case INST_JUMP_FALSE4:
jmpOffset[0] = TclGetInt4AtPtr(pc+1); /* FALSE offset */
jmpOffset[1] = 5; /* TRUE offset*/
@@ -2452,35 +2628,17 @@ TclExecuteByteCode(interp, codePtr)
doCondJump:
valuePtr = *tosPtr;
- if (valuePtr->typePtr == &tclIntType) {
- b = (valuePtr->internalRep.longValue != 0);
- } else if (valuePtr->typePtr == &tclDoubleType) {
- b = (valuePtr->internalRep.doubleValue != 0.0);
- } else if (valuePtr->typePtr == &tclWideIntType) {
- Tcl_WideInt w;
-
- TclGetWide(w,valuePtr);
- b = (w != W0);
- } else {
- /*
- * Taking b's address impedes it being a register variable (in gcc
- * at least), so we avoid doing it.
- */
- int b1;
- result = Tcl_GetBooleanFromObj(interp, valuePtr, &b1);
- if (result != TCL_OK) {
- if ((*pc == INST_JUMP_FALSE1) || (*pc == INST_JUMP_FALSE4)) {
- jmpOffset[1] = jmpOffset[0];
- }
- TRACE_WITH_OBJ(("%d => ERROR: ", jmpOffset[1]),
- Tcl_GetObjResult(interp));
- goto checkForCatch;
- }
- b = b1;
+ /* TODO - check claim that taking address of b harms performance */
+ /* TODO - consider optimization search for eePtr->constants */
+ result = TclGetBooleanFromObj(interp, valuePtr, &b);
+ if (result != TCL_OK) {
+ TRACE_WITH_OBJ(("%d => ERROR: ", jmpOffset[
+ ((*pc == INST_JUMP_FALSE1) || (*pc == INST_JUMP_FALSE4))
+ ? 0 : 1]), Tcl_GetObjResult(interp));
+ goto checkForCatch;
}
-#ifndef TCL_COMPILE_DEBUG
- NEXT_INST_F(jmpOffset[b], 1, 0);
-#else
+
+#ifdef TCL_COMPILE_DEBUG
if (b) {
if ((*pc == INST_JUMP_TRUE1) || (*pc == INST_JUMP_TRUE4)) {
TRACE(("%d => %.20s true, new pc %u\n", jmpOffset[1], O2S(valuePtr),
@@ -2488,7 +2646,6 @@ TclExecuteByteCode(interp, codePtr)
} else {
TRACE(("%d => %.20s true\n", jmpOffset[0], O2S(valuePtr)));
}
- NEXT_INST_F(jmpOffset[1], 1, 0);
} else {
if ((*pc == INST_JUMP_TRUE1) || (*pc == INST_JUMP_TRUE4)) {
TRACE(("%d => %.20s false\n", jmpOffset[0], O2S(valuePtr)));
@@ -2496,9 +2653,9 @@ TclExecuteByteCode(interp, codePtr)
TRACE(("%d => %.20s false, new pc %u\n", jmpOffset[0], O2S(valuePtr),
(unsigned int)(pc + jmpOffset[1] - codePtr->codeStart)));
}
- NEXT_INST_F(jmpOffset[0], 1, 0);
}
#endif
+ NEXT_INST_F(jmpOffset[b], 1, 0);
}
/*
@@ -2514,94 +2671,34 @@ TclExecuteByteCode(interp, codePtr)
* performed.
*/
- int i1, i2, length;
- int iResult;
- char *s;
- Tcl_ObjType *t1Ptr, *t2Ptr;
- Tcl_Obj *valuePtr, *value2Ptr;
- Tcl_WideInt w;
-
- value2Ptr = *tosPtr;
- valuePtr = *(tosPtr - 1);
- t1Ptr = valuePtr->typePtr;
- t2Ptr = value2Ptr->typePtr;
-
- if (t1Ptr == &tclIntType) {
- i1 = (valuePtr->internalRep.longValue != 0);
- } else if (t1Ptr == &tclWideIntType) {
- TclGetWide(w,valuePtr);
- i1 = (w != W0);
- } else if (t1Ptr == &tclDoubleType) {
- i1 = (valuePtr->internalRep.doubleValue != 0.0);
- } else {
- s = Tcl_GetStringFromObj(valuePtr, &length);
- if (TclLooksLikeInt(s, length)) {
- long i = 0;
+ int i1, i2, iResult;
+ Tcl_Obj *value2Ptr = *tosPtr;
+ Tcl_Obj *valuePtr = *(tosPtr - 1);
- GET_WIDE_OR_INT(result, valuePtr, i, w);
- if (valuePtr->typePtr == &tclIntType) {
- i1 = (i != 0);
- } else {
- i1 = (w != W0);
- }
- } else {
- result = Tcl_GetBooleanFromObj(NULL, valuePtr, &i1);
- }
- if (result != TCL_OK) {
- TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(valuePtr),
- (t1Ptr? t1Ptr->name : "null")));
- IllegalExprOperandType(interp, pc, valuePtr);
- goto checkForCatch;
- }
+ result = TclGetBooleanFromObj(NULL, valuePtr, &i1);
+ if (result != TCL_OK) {
+ TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(valuePtr),
+ (valuePtr->typePtr? valuePtr->typePtr->name : "null")));
+ IllegalExprOperandType(interp, pc, valuePtr);
+ goto checkForCatch;
}
- if (t2Ptr == &tclIntType) {
- i2 = (value2Ptr->internalRep.longValue != 0);
- } else if (t2Ptr == &tclWideIntType) {
- TclGetWide(w,value2Ptr);
- i2 = (w != W0);
- } else if (t2Ptr == &tclDoubleType) {
- i2 = (value2Ptr->internalRep.doubleValue != 0.0);
- } else {
- s = Tcl_GetStringFromObj(value2Ptr, &length);
- if (TclLooksLikeInt(s, length)) {
- long i = 0;
-
- GET_WIDE_OR_INT(result, value2Ptr, i, w);
- if (value2Ptr->typePtr == &tclIntType) {
- i2 = (i != 0);
- } else {
- i2 = (w != W0);
- }
- } else {
- result = Tcl_GetBooleanFromObj(NULL, value2Ptr, &i2);
- }
- if (result != TCL_OK) {
- TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(value2Ptr),
- (t2Ptr? t2Ptr->name : "null")));
- IllegalExprOperandType(interp, pc, value2Ptr);
- goto checkForCatch;
- }
+ result = TclGetBooleanFromObj(NULL, value2Ptr, &i2);
+ if (result != TCL_OK) {
+ TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(value2Ptr),
+ (value2Ptr->typePtr? value2Ptr->typePtr->name : "null")));
+ IllegalExprOperandType(interp, pc, value2Ptr);
+ goto checkForCatch;
}
- /*
- * Reuse the valuePtr object already on stack if possible.
- */
-
if (*pc == INST_LOR) {
iResult = (i1 || i2);
} else {
iResult = (i1 && i2);
}
- if (Tcl_IsShared(valuePtr)) {
- TclNewLongObj(objResultPtr, iResult);
- TRACE(("%.20s %.20s => %d\n", O2S(valuePtr), O2S(value2Ptr), iResult));
- NEXT_INST_F(1, 2, 1);
- } else { /* reuse the valuePtr object */
- TRACE(("%.20s %.20s => %d\n", O2S(valuePtr), O2S(value2Ptr), iResult));
- TclSetLongObj(valuePtr, iResult);
- NEXT_INST_F(1, 1, 0);
- }
+ objResultPtr = eePtr->constants[iResult];
+ TRACE(("%.20s %.20s => %d\n", O2S(valuePtr), O2S(value2Ptr), iResult));
+ NEXT_INST_F(1, 2, 1);
}
/*
@@ -2930,6 +3027,7 @@ TclExecuteByteCode(interp, codePtr)
value2Ptr = *tosPtr;
valuePtr = *(tosPtr - 1);
+ /* TODO: Consider more efficient tests than strcmp() */
s1 = Tcl_GetStringFromObj(valuePtr, &s1len);
result = Tcl_ListObjLength(interp, value2Ptr, &llen);
if (result != TCL_OK) {
@@ -2963,6 +3061,8 @@ TclExecuteByteCode(interp, codePtr)
/*
* Peep-hole optimisation: if you're about to jump, do jump from here.
+ * We're saving the effort of pushing a boolean value only to pop it
+ * for branching.
*/
pc++;
@@ -2978,7 +3078,7 @@ TclExecuteByteCode(interp, codePtr)
NEXT_INST_F((found ? TclGetInt4AtPtr(pc+1) : 5), 2, 0);
}
#endif
- TclNewIntObj(objResultPtr, found);
+ objResultPtr = eePtr->constants[found];
NEXT_INST_F(0, 2, 1);
}
@@ -2991,6 +3091,7 @@ TclExecuteByteCode(interp, codePtr)
case INST_STR_NEQ: {
/*
* String (in)equality check
+ * TODO: Consider merging into INST_STR_CMP
*/
int iResult;
Tcl_Obj *valuePtr, *value2Ptr;
@@ -3057,6 +3158,7 @@ TclExecuteByteCode(interp, codePtr)
int s1len, s2len, iResult;
Tcl_Obj *valuePtr, *value2Ptr;
+ stringCompare:
value2Ptr = *tosPtr;
valuePtr = *(tosPtr - 1);
@@ -3108,18 +3210,44 @@ TclExecuteByteCode(interp, codePtr)
/*
* Make sure only -1,0,1 is returned
+ * TODO: consider peephole opt.
*/
if (iResult == 0) {
iResult = s1len - s2len;
}
+
+ if (*pc != INST_STR_CMP) {
+ /* Take care of the opcodes that goto'ed into here */
+ switch (*pc) {
+ case INST_EQ:
+ iResult = (iResult == 0);
+ break;
+ case INST_NEQ:
+ iResult = (iResult != 0);
+ break;
+ case INST_LT:
+ iResult = (iResult < 0);
+ break;
+ case INST_GT:
+ iResult = (iResult > 0);
+ break;
+ case INST_LE:
+ iResult = (iResult <= 0);
+ break;
+ case INST_GE:
+ iResult = (iResult >= 0);
+ break;
+ }
+ }
if (iResult < 0) {
- iResult = -1;
- } else if (iResult > 0) {
- iResult = 1;
+ TclNewIntObj(objResultPtr, -1);
+ TRACE(("%.20s %.20s => %d\n", O2S(valuePtr), O2S(value2Ptr), -1));
+ } else {
+ objResultPtr = eePtr->constants[(iResult>0)];
+ TRACE(("%.20s %.20s => %d\n", O2S(valuePtr), O2S(value2Ptr),
+ (iResult > 0)));
}
- TclNewIntObj(objResultPtr, iResult);
- TRACE(("%.20s %.20s => %d\n", O2S(valuePtr), O2S(value2Ptr), iResult));
NEXT_INST_F(1, 2, 1);
}
@@ -3230,6 +3358,7 @@ TclExecuteByteCode(interp, codePtr)
/*
* Reuse value2Ptr object already on stack if possible. Adjustment is
* 2 due to the nocase byte
+ * TODO: consider peephole opt.
*/
TRACE(("%.20s %.20s => %d\n", O2S(valuePtr), O2S(value2Ptr), match));
@@ -3243,251 +3372,293 @@ TclExecuteByteCode(interp, codePtr)
case INST_GT:
case INST_LE:
case INST_GE: {
- /*
- * Any type is allowed but the two operands must have the same type.
- * We will compute value op value2.
- */
-
- Tcl_ObjType *t1Ptr, *t2Ptr;
- char *s1 = NULL; /* Init. avoids compiler warning. */
- char *s2 = NULL; /* Init. avoids compiler warning. */
- long i2 = 0; /* Init. avoids compiler warning. */
- double d1 = 0.0; /* Init. avoids compiler warning. */
- double d2 = 0.0; /* Init. avoids compiler warning. */
- long iResult = 0; /* Init. avoids compiler warning. */
- Tcl_Obj *valuePtr, *value2Ptr;
- int length;
- Tcl_WideInt w;
- long i;
-
- value2Ptr = *tosPtr;
- valuePtr = *(tosPtr - 1);
-
- /*
- * Be careful in the equal-object case; 'NaN' isn't supposed to be
- * equal to even itself. [Bug 761471]
- */
-
- t1Ptr = valuePtr->typePtr;
+ Tcl_Obj *valuePtr = *(tosPtr - 1);
+ Tcl_Obj *value2Ptr = *tosPtr;
+ ClientData ptr1, ptr2;
+ int iResult, compare, type1, type2;
+ double d1, d2, tmp;
+ long l1, l2;
+ Tcl_WideInt w1, w2;
+ mp_int big1, big2;
+
+ if (GetNumberFromObj(NULL, valuePtr, &ptr1, &type1) != TCL_OK) {
+ /* At least one non-numeric argument - compare as strings */
+ goto stringCompare;
+ }
+ if (type1 == TCL_NUMBER_NAN) {
+ /* NaN first arg: NaN != to everything, other compares are false */
+ iResult = (*pc == INST_NEQ);
+ goto foundResult;
+ }
if (valuePtr == value2Ptr) {
- /*
- * If we are numeric already, or a dictionary (which is never like
- * a single-element list), we can proceed to the main equality
- * check right now. Otherwise, we need to try to coerce to a
- * numeric type so we can see if we've got a NaN but haven't
- * parsed it as numeric.
- */
- if (!IS_NUMERIC_TYPE(t1Ptr) && (t1Ptr != &tclDictType)) {
- if (t1Ptr == &tclListType) {
- int length;
- /*
- * Only a list of length 1 can be NaN or such things.
- */
- (void) Tcl_ListObjLength(NULL, valuePtr, &length);
- if (length == 1) {
- goto mustConvertForNaNCheck;
- }
- } else {
- /*
- * Too bad, we'll have to compute the string and try the
- * conversion
- */
-
- mustConvertForNaNCheck:
- s1 = Tcl_GetStringFromObj(valuePtr, &length);
- if (TclLooksLikeInt(s1, length)) {
- GET_WIDE_OR_INT(iResult, valuePtr, i, w);
- } else {
- (void) Tcl_GetDoubleFromObj((Tcl_Interp *) NULL,
- valuePtr, &d1);
- }
- t1Ptr = valuePtr->typePtr;
- }
- }
-
- switch (*pc) {
- case INST_EQ:
- case INST_LE:
- case INST_GE:
- iResult = !((t1Ptr == &tclDoubleType)
- && IS_NAN(valuePtr->internalRep.doubleValue));
- break;
- case INST_LT:
- case INST_GT:
- iResult = 0;
- break;
- case INST_NEQ:
- iResult = ((t1Ptr == &tclDoubleType)
- && IS_NAN(valuePtr->internalRep.doubleValue));
- break;
- }
+ compare = MP_EQ;
+ goto convertComparison;
+ }
+ if (GetNumberFromObj(NULL, value2Ptr, &ptr2, &type2) != TCL_OK) {
+ /* At least one non-numeric argument - compare as strings */
+ goto stringCompare;
+ }
+ if (type2 == TCL_NUMBER_NAN) {
+ /* NaN 2nd arg: NaN != to everything, other compares are false */
+ iResult = (*pc == INST_NEQ);
goto foundResult;
}
-
- t2Ptr = value2Ptr->typePtr;
-
- /*
- * We only want to coerce numeric validation if neither type is NULL.
- * A NULL type means the arg is essentially an empty object ("", {} or
- * [list]).
- */
- if (!( (!t1Ptr && !valuePtr->bytes)
- || (valuePtr->bytes && !valuePtr->length)
- || (!t2Ptr && !value2Ptr->bytes)
- || (value2Ptr->bytes && !value2Ptr->length))) {
- if (!IS_NUMERIC_TYPE(t1Ptr)) {
- s1 = Tcl_GetStringFromObj(valuePtr, &length);
- if (TclLooksLikeInt(s1, length)) {
- GET_WIDE_OR_INT(iResult, valuePtr, i, w);
+ switch (type1) {
+ case TCL_NUMBER_LONG:
+ l1 = *((CONST long *)ptr1);
+ switch (type2) {
+ case TCL_NUMBER_LONG:
+ l2 = *((CONST long *)ptr2);
+ longCompare:
+ compare = (l1 < l2) ? MP_LT : ((l1 > l2) ? MP_GT : MP_EQ);
+ break;
+#ifndef NO_WIDE_TYPE
+ case TCL_NUMBER_WIDE:
+ w2 = *((CONST Tcl_WideInt *)ptr2);
+ w1 = (Tcl_WideInt)l1;
+ goto wideCompare;
+#endif
+ case TCL_NUMBER_DOUBLE:
+ d2 = *((CONST double *)ptr2);
+ d1 = (double) l1;
+
+ /*
+ * If the double has a fractional part, or if the
+ * long can be converted to double without loss of
+ * precision, then compare as doubles.
+ */
+ if ((DBL_MANT_DIG > CHAR_BIT*sizeof(long))
+ || (l1 == (long) d1) || (modf(d2, &tmp) != 0.0)) {
+ goto doubleCompare;
+ }
+ /*
+ * Otherwise, to make comparision based on full precision,
+ * need to convert the double to a suitably sized integer.
+ *
+ * Need this to get comparsions like
+ * expr 20000000000000003 < 20000000000000004.0
+ * right. Converting the first argument to double
+ * will yield two double values that are equivalent
+ * within double precision. Converting the double to
+ * an integer gets done exactly, then integer comparison
+ * can tell the difference.
+ */
+ if (d2 < (double)LONG_MIN) {
+ compare = MP_GT;
+ break;
+ }
+ if (d2 > (double)LONG_MAX) {
+ compare = MP_LT;
+ break;
+ }
+ l2 = (long) d2;
+ goto longCompare;
+ case TCL_NUMBER_BIG:
+ if (Tcl_IsShared(value2Ptr)) {
+ Tcl_GetBignumFromObj(NULL, value2Ptr, &big2);
} else {
- (void) Tcl_GetDoubleFromObj((Tcl_Interp *) NULL,
- valuePtr, &d1);
+ Tcl_GetBignumAndClearObj(NULL, value2Ptr, &big2);
}
- t1Ptr = valuePtr->typePtr;
- }
- if (!IS_NUMERIC_TYPE(t2Ptr)) {
- s2 = Tcl_GetStringFromObj(value2Ptr, &length);
- if (TclLooksLikeInt(s2, length)) {
- GET_WIDE_OR_INT(iResult, value2Ptr, i2, w);
+ if (mp_cmp_d(&big2, 0) == MP_LT) {
+ compare = MP_GT;
} else {
- (void) Tcl_GetDoubleFromObj((Tcl_Interp *) NULL,
- value2Ptr, &d2);
+ compare = MP_LT;
}
- t2Ptr = value2Ptr->typePtr;
+ mp_clear(&big2);
}
- }
- if (!IS_NUMERIC_TYPE(t1Ptr) || !IS_NUMERIC_TYPE(t2Ptr)) {
- /*
- * One operand is not numeric. Compare as strings. NOTE: strcmp
- * is not correct for \x00 < \x01, but that is unlikely to occur
- * here. We could use the TclUtfNCmp2 to handle this.
- */
- int s1len, s2len;
- s1 = Tcl_GetStringFromObj(valuePtr, &s1len);
- s2 = Tcl_GetStringFromObj(value2Ptr, &s2len);
- switch (*pc) {
- case INST_EQ:
- if (s1len == s2len) {
- iResult = (strcmp(s1, s2) == 0);
+ break;
+
+#ifndef NO_WIDE_TYPE
+ case TCL_NUMBER_WIDE:
+ w1 = *((CONST Tcl_WideInt *)ptr1);
+ switch (type2) {
+ case TCL_NUMBER_WIDE:
+ w2 = *((CONST Tcl_WideInt *)ptr2);
+ wideCompare:
+ compare = (w1 < w2) ? MP_LT : ((w1 > w2) ? MP_GT : MP_EQ);
+ break;
+ case TCL_NUMBER_LONG:
+ l2 = *((CONST long *)ptr2);
+ w2 = (Tcl_WideInt)l2;
+ goto wideCompare;
+ case TCL_NUMBER_DOUBLE:
+ d2 = *((CONST double *)ptr2);
+ d1 = (double) w1;
+ if ((DBL_MANT_DIG > CHAR_BIT*sizeof(Tcl_WideInt))
+ || (w1 == (Tcl_WideInt) d1) || (modf(d2, &tmp) != 0.0)) {
+ goto doubleCompare;
+ }
+ if (d2 < (double)LLONG_MIN) {
+ compare = MP_GT;
+ break;
+ }
+ if (d2 > (double)LLONG_MAX) {
+ compare = MP_LT;
+ break;
+ }
+ w2 = (Tcl_WideInt) d2;
+ goto wideCompare;
+ case TCL_NUMBER_BIG:
+ if (Tcl_IsShared(value2Ptr)) {
+ Tcl_GetBignumFromObj(NULL, value2Ptr, &big2);
} else {
- iResult = 0;
+ Tcl_GetBignumAndClearObj(NULL, value2Ptr, &big2);
}
- break;
- case INST_NEQ:
- if (s1len == s2len) {
- iResult = (strcmp(s1, s2) != 0);
+ if (mp_cmp_d(&big2, 0) == MP_LT) {
+ compare = MP_GT;
} else {
- iResult = 1;
+ compare = MP_LT;
}
- break;
- case INST_LT:
- iResult = (strcmp(s1, s2) < 0);
- break;
- case INST_GT:
- iResult = (strcmp(s1, s2) > 0);
- break;
- case INST_LE:
- iResult = (strcmp(s1, s2) <= 0);
- break;
- case INST_GE:
- iResult = (strcmp(s1, s2) >= 0);
- break;
+ mp_clear(&big2);
}
- } else if ((t1Ptr == &tclDoubleType) || (t2Ptr == &tclDoubleType)) {
- /*
- * Compare as doubles.
- */
- if (t1Ptr == &tclDoubleType) {
- d1 = valuePtr->internalRep.doubleValue;
- GET_DOUBLE_VALUE(d2, value2Ptr, t2Ptr);
- } else { /* t1Ptr is integer, t2Ptr is double */
- GET_DOUBLE_VALUE(d1, valuePtr, t1Ptr);
- d2 = value2Ptr->internalRep.doubleValue;
- }
- switch (*pc) {
- case INST_EQ:
- iResult = d1 == d2;
- break;
- case INST_NEQ:
- iResult = d1 != d2;
- break;
- case INST_LT:
- iResult = d1 < d2;
- break;
- case INST_GT:
- iResult = d1 > d2;
- break;
- case INST_LE:
- iResult = d1 <= d2;
- break;
- case INST_GE:
- iResult = d1 >= d2;
+ break;
+#endif
+
+ case TCL_NUMBER_DOUBLE:
+ d1 = *((CONST double *)ptr1);
+ switch (type2) {
+ case TCL_NUMBER_DOUBLE:
+ d2 = *((CONST double *)ptr2);
+ doubleCompare:
+ compare = (d1 < d2) ? MP_LT : ((d1 > d2) ? MP_GT : MP_EQ);
break;
+ case TCL_NUMBER_LONG:
+ l2 = *((CONST long *)ptr2);
+ d2 = (double) l2;
+
+ if ((DBL_MANT_DIG > CHAR_BIT*sizeof(long))
+ || (l2 == (long) d2) || (modf(d1, &tmp) != 0.0)) {
+ goto doubleCompare;
+ }
+ if (d1 < (double)LONG_MIN) {
+ compare = MP_LT;
+ break;
+ }
+ if (d1 > (double)LONG_MAX) {
+ compare = MP_GT;
+ break;
+ }
+ l1 = (long) d1;
+ goto longCompare;
+#ifndef NO_WIDE_TYPE
+ case TCL_NUMBER_WIDE:
+ w2 = *((CONST Tcl_WideInt *)ptr2);
+ d2 = (double) w2;
+ if ((DBL_MANT_DIG > CHAR_BIT*sizeof(Tcl_WideInt))
+ || (w2 == (Tcl_WideInt) d2) || (modf(d1, &tmp) != 0.0)) {
+ goto doubleCompare;
+ }
+ if (d1 < (double)LLONG_MIN) {
+ compare = MP_LT;
+ break;
+ }
+ if (d1 > (double)LLONG_MAX) {
+ compare = MP_GT;
+ break;
+ }
+ w1 = (Tcl_WideInt) d1;
+ goto wideCompare;
+#endif
+ case TCL_NUMBER_BIG:
+ if (TclIsInfinite(d1)) {
+ compare = (d1 > 0.0) ? MP_GT : MP_LT;
+ break;
+ }
+ if (Tcl_IsShared(value2Ptr)) {
+ Tcl_GetBignumFromObj(NULL, value2Ptr, &big2);
+ } else {
+ Tcl_GetBignumAndClearObj(NULL, value2Ptr, &big2);
+ }
+ if ((d1 < (double)LONG_MAX) && (d1 > (double)LONG_MIN)) {
+ if (mp_cmp_d(&big2, 0) == MP_LT) {
+ compare = MP_GT;
+ } else {
+ compare = MP_LT;
+ }
+ mp_clear(&big2);
+ break;
+ }
+ if ((DBL_MANT_DIG > CHAR_BIT*sizeof(long))
+ && (modf(d1, &tmp) != 0.0)) {
+ d2 = TclBignumToDouble( &big2);
+ mp_clear(&big2);
+ goto doubleCompare;
+ }
+ TclInitBignumFromDouble(NULL, d1, &big1);
+ goto bigCompare;
}
- } else if ((t1Ptr == &tclWideIntType) || (t2Ptr == &tclWideIntType)) {
- Tcl_WideInt w2;
- /*
- * Compare as wide ints (neither are doubles)
- */
- if (t1Ptr == &tclIntType) {
- w = Tcl_LongAsWide(valuePtr->internalRep.longValue);
- TclGetWide(w2,value2Ptr);
- } else if (t2Ptr == &tclIntType) {
- TclGetWide(w,valuePtr);
- w2 = Tcl_LongAsWide(value2Ptr->internalRep.longValue);
+ break;
+
+ case TCL_NUMBER_BIG:
+ if (Tcl_IsShared(valuePtr)) {
+ Tcl_GetBignumFromObj(NULL, valuePtr, &big1);
} else {
- TclGetWide(w,valuePtr);
- TclGetWide(w2,value2Ptr);
+ Tcl_GetBignumAndClearObj(NULL, valuePtr, &big1);
}
- switch (*pc) {
- case INST_EQ:
- iResult = w == w2;
- break;
- case INST_NEQ:
- iResult = w != w2;
- break;
- case INST_LT:
- iResult = w < w2;
- break;
- case INST_GT:
- iResult = w > w2;
- break;
- case INST_LE:
- iResult = w <= w2;
- break;
- case INST_GE:
- iResult = w >= w2;
- break;
- }
- } else {
- /*
- * Compare as ints.
- */
- i = valuePtr->internalRep.longValue;
- i2 = value2Ptr->internalRep.longValue;
- switch (*pc) {
- case INST_EQ:
- iResult = i == i2;
- break;
- case INST_NEQ:
- iResult = i != i2;
- break;
- case INST_LT:
- iResult = i < i2;
- break;
- case INST_GT:
- iResult = i > i2;
- break;
- case INST_LE:
- iResult = i <= i2;
- break;
- case INST_GE:
- iResult = i >= i2;
+ switch (type2) {
+#ifndef NO_WIDE_TYPE
+ case TCL_NUMBER_WIDE:
+#endif
+ case TCL_NUMBER_LONG:
+ compare = mp_cmp_d(&big1, 0);
+ mp_clear(&big1);
break;
+ case TCL_NUMBER_DOUBLE:
+ d2 = *((CONST double *)ptr2);
+ if (TclIsInfinite(d2)) {
+ compare = (d2 > 0.0) ? MP_LT : MP_GT;
+ mp_clear(&big1);
+ break;
+ }
+ if ((d2 < (double)LONG_MAX) && (d2 > (double)LONG_MIN)) {
+ compare = mp_cmp_d(&big1, 0);
+ mp_clear(&big1);
+ break;
+ }
+ if ((DBL_MANT_DIG > CHAR_BIT*sizeof(long))
+ && (modf(d2, &tmp) != 0.0)) {
+ d1 = TclBignumToDouble( &big1);
+ mp_clear(&big1);
+ goto doubleCompare;
+ }
+ TclInitBignumFromDouble(NULL, d2, &big2);
+ goto bigCompare;
+ case TCL_NUMBER_BIG:
+ if (Tcl_IsShared(value2Ptr)) {
+ Tcl_GetBignumFromObj(NULL, value2Ptr, &big2);
+ } else {
+ Tcl_GetBignumAndClearObj(NULL, value2Ptr, &big2);
+ }
+ bigCompare:
+ compare = mp_cmp(&big1, &big2);
+ mp_clear(&big1);
+ mp_clear(&big2);
}
}
- TRACE(("%.20s %.20s => %ld\n", O2S(valuePtr), O2S(value2Ptr), iResult));
+ /* Turn comparison outcome into appropriate result for opcode */
+
+ convertComparison:
+ switch (*pc) {
+ case INST_EQ:
+ iResult = (compare == MP_EQ);
+ break;
+ case INST_NEQ:
+ iResult = (compare != MP_EQ);
+ break;
+ case INST_LT:
+ iResult = (compare == MP_LT);
+ break;
+ case INST_GT:
+ iResult = (compare == MP_GT);
+ break;
+ case INST_LE:
+ iResult = (compare != MP_GT);
+ break;
+ case INST_GE:
+ iResult = (compare != MP_LT);
+ break;
+ }
/*
* Peep-hole optimisation: if you're about to jump, do jump from here.
@@ -3511,12 +3682,445 @@ TclExecuteByteCode(interp, codePtr)
NEXT_INST_F(0, 2, 1);
}
- case INST_MOD:
case INST_LSHIFT:
- case INST_RSHIFT:
+ case INST_RSHIFT: {
+ Tcl_Obj *value2Ptr = *tosPtr;
+ Tcl_Obj *valuePtr = *(tosPtr - 1);
+ ClientData ptr1, ptr2;
+ int invalid, shift, type1, type2;
+ long l;
+
+ result = GetNumberFromObj(NULL, valuePtr, &ptr1, &type1);
+ if ((result != TCL_OK)
+ || (type1 == TCL_NUMBER_DOUBLE) || (type1 == TCL_NUMBER_NAN)) {
+ result = TCL_ERROR;
+ TRACE(("%.20s %.20s => ILLEGAL 1st TYPE %s\n", O2S(valuePtr),
+ O2S(value2Ptr), (valuePtr->typePtr?
+ valuePtr->typePtr->name : "null")));
+ IllegalExprOperandType(interp, pc, valuePtr);
+ goto checkForCatch;
+ }
+
+ result = GetNumberFromObj(NULL, value2Ptr, &ptr2, &type2);
+ if ((result != TCL_OK)
+ || (type2 == TCL_NUMBER_DOUBLE) || (type2 == TCL_NUMBER_NAN)) {
+ result = TCL_ERROR;
+ TRACE(("%.20s %.20s => ILLEGAL 2nd TYPE %s\n", O2S(valuePtr),
+ O2S(value2Ptr), (value2Ptr->typePtr?
+ value2Ptr->typePtr->name : "null")));
+ IllegalExprOperandType(interp, pc, value2Ptr);
+ goto checkForCatch;
+ }
+
+ /* reject negative shift argument */
+ switch (type2) {
+ case TCL_NUMBER_LONG:
+ invalid = (*((CONST long *)ptr2) < (long)0);
+ break;
+#ifndef NO_WIDE_TYPE
+ case TCL_NUMBER_WIDE:
+ invalid = (*((CONST Tcl_WideInt *)ptr2) < (Tcl_WideInt)0);
+ break;
+#endif
+ case TCL_NUMBER_BIG:
+ /* TODO: const correctness ? */
+ invalid = (mp_cmp_d((mp_int *)ptr2, 0) == MP_LT);
+ }
+ if (invalid) {
+ Tcl_SetObjResult(interp,
+ Tcl_NewStringObj("negative shift argument", -1));
+ result = TCL_ERROR;
+ goto checkForCatch;
+ }
+
+ /* Zero shifted any number of bits is still zero */
+ if ((type1 == TCL_NUMBER_LONG) && (*((CONST long *)ptr1) == (long)0)) {
+ TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr)));
+ objResultPtr = eePtr->constants[0];
+ TRACE(("%s\n", O2S(objResultPtr)));
+ NEXT_INST_F(1, 2, 1);
+ }
+
+ if (*pc == INST_LSHIFT) {
+ /* Large left shifts create integer overflow */
+ result = Tcl_GetIntFromObj(NULL, value2Ptr, &shift);
+ if (result != TCL_OK) {
+ /*
+ * Technically, we could hold the value (1 << (INT_MAX+1))
+ * in an mp_int, but since we're using mp_mul_2d() to do the
+ * work, and it takes only an int argument, that's a good
+ * place to draw the line.
+ */
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "integer value too large to represent", -1));
+ goto checkForCatch;
+ }
+ /* Handle shifts within the native long range */
+ TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr)));
+ if ((type1 == TCL_NUMBER_LONG) && (shift < CHAR_BIT*sizeof(long))
+ && (l = *((CONST long *)ptr1))
+ && !(((l>0) ? l : ~l)
+ & -(1<<(CHAR_BIT*sizeof(long)-1-shift)))) {
+ TclNewLongObj(objResultPtr, (l<<shift));
+ TRACE(("%s\n", O2S(objResultPtr)));
+ NEXT_INST_F(1, 2, 1);
+ }
+
+ /* Handle shifts within the native wide range */
+ TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr)));
+ if ((type1 != TCL_NUMBER_BIG)
+ && (shift < CHAR_BIT*sizeof(Tcl_WideInt))) {
+ Tcl_WideInt w;
+ TclGetWideIntFromObj(NULL, valuePtr, &w);
+ if (!(((w>0) ? w : ~w)
+ & -(((Tcl_WideInt)1)
+ <<(CHAR_BIT*sizeof(Tcl_WideInt)-1-shift)))) {
+ objResultPtr = Tcl_NewWideIntObj(w<<shift);
+ TRACE(("%s\n", O2S(objResultPtr)));
+ NEXT_INST_F(1, 2, 1);
+ }
+ }
+
+/*
+ if ((type1 == TCL_NUMBER_LONG) && (shift < CHAR_BIT*sizeof(long))
+ && (l = *((CONST long *)ptr1))
+ && !(((l>0) ? l : ~l)
+ & -(1<<(CHAR_BIT*sizeof(long)-1-shift)))) {
+ TclNewLongObj(objResultPtr, (l<<shift));
+ TRACE(("%s\n", O2S(objResultPtr)));
+ NEXT_INST_F(1, 2, 1);
+ }
+*/
+
+
+
+ } else {
+ /* Quickly force large right shifts to 0 or -1 */
+ TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr)));
+ if ((type2 != TCL_NUMBER_LONG)
+ || ( *((CONST long *)ptr2) > INT_MAX)) {
+ /*
+ * Again, technically, the value to be shifted could
+ * be an mp_int so huge that a right shift by (INT_MAX+1)
+ * bits could not take us to the result of 0 or -1, but
+ * since we're using mp_div_2d to do the work, and it
+ * takes only an int argument, we draw the line there.
+ */
+ int zero;
+ switch (type1) {
+ case TCL_NUMBER_LONG:
+ zero = (*((CONST long *)ptr1) > (long)0);
+ break;
+#ifndef NO_WIDE_TYPE
+ case TCL_NUMBER_WIDE:
+ zero = (*((CONST Tcl_WideInt *)ptr1) > (Tcl_WideInt)0);
+ break;
+#endif
+ case TCL_NUMBER_BIG:
+ /* TODO: const correctness ? */
+ zero = (mp_cmp_d((mp_int *)ptr1, 0) == MP_GT);
+ }
+ if (zero) {
+ objResultPtr = eePtr->constants[0];
+ } else {
+ TclNewIntObj(objResultPtr, -1);
+ }
+ TRACE(("%s\n", O2S(objResultPtr)));
+ NEXT_INST_F(1, 2, 1);
+ }
+ shift = (int)(*((CONST long *)ptr2));
+ /* Handle shifts within the native long range */
+ if (type1 == TCL_NUMBER_LONG) {
+ long l = *((CONST long *)ptr1);
+ if (shift >= CHAR_BIT*sizeof(long)) {
+ if (l >= (long)0) {
+ objResultPtr = eePtr->constants[0];
+ } else {
+ TclNewIntObj(objResultPtr, -1);
+ }
+ } else {
+ TclNewLongObj(objResultPtr, (l >> shift));
+ }
+ TRACE(("%s\n", O2S(objResultPtr)));
+ NEXT_INST_F(1, 2, 1);
+ }
+#ifndef NO_WIDE_TYPE
+ /* Handle shifts within the native wide range */
+ if (type1 == TCL_NUMBER_WIDE) {
+ Tcl_WideInt w = *((CONST Tcl_WideInt *)ptr1);
+ if (shift >= CHAR_BIT*sizeof(Tcl_WideInt)) {
+ if (w >= (Tcl_WideInt)0) {
+ objResultPtr = eePtr->constants[0];
+ } else {
+ TclNewIntObj(objResultPtr, -1);
+ }
+ } else {
+ objResultPtr = Tcl_NewWideIntObj(w >> shift);
+ }
+ TRACE(("%s\n", O2S(objResultPtr)));
+ NEXT_INST_F(1, 2, 1);
+ }
+#endif
+ }
+
+ {
+ mp_int big, bigResult, bigRemainder;
+
+ if (Tcl_IsShared(valuePtr)) {
+ Tcl_GetBignumFromObj(NULL, valuePtr, &big);
+ } else {
+ Tcl_GetBignumAndClearObj(NULL, valuePtr, &big);
+ }
+
+ mp_init(&bigResult);
+ if (*pc == INST_LSHIFT) {
+ mp_mul_2d(&big, shift, &bigResult);
+ } else {
+ mp_init(&bigRemainder);
+ mp_div_2d(&big, shift, &bigResult, &bigRemainder);
+ if (mp_cmp_d(&bigRemainder, 0) == MP_LT) {
+ /* Convert to Tcl's integer division rules */
+ mp_sub_d(&bigResult, 1, &bigResult);
+ }
+ mp_clear(&bigRemainder);
+ }
+ mp_clear(&big);
+
+ if (!Tcl_IsShared(valuePtr)) {
+ Tcl_SetBignumObj(valuePtr, &bigResult);
+ TRACE(("%s\n", O2S(valuePtr)));
+ NEXT_INST_F(1, 1, 0);
+ }
+ objResultPtr = Tcl_NewBignumObj(&bigResult);
+ }
+ TRACE(("%s\n", O2S(objResultPtr)));
+ NEXT_INST_F(1, 2, 1);
+ }
+
case INST_BITOR:
case INST_BITXOR:
case INST_BITAND: {
+ ClientData ptr1, ptr2;
+ int type1, type2;
+ Tcl_Obj *value2Ptr = *tosPtr;
+ Tcl_Obj *valuePtr = *(tosPtr - 1);
+
+ result = GetNumberFromObj(NULL, valuePtr, &ptr1, &type1);
+ if ((result != TCL_OK)
+ || (type1 == TCL_NUMBER_NAN) || (type1 == TCL_NUMBER_DOUBLE)) {
+ result = TCL_ERROR;
+ TRACE(("%.20s %.20s => ILLEGAL 1st TYPE %s\n", O2S(valuePtr),
+ O2S(value2Ptr), (valuePtr->typePtr?
+ valuePtr->typePtr->name : "null")));
+ IllegalExprOperandType(interp, pc, valuePtr);
+ goto checkForCatch;
+ }
+ result = GetNumberFromObj(NULL, value2Ptr, &ptr2, &type2);
+ if ((result != TCL_OK)
+ || (type2 == TCL_NUMBER_NAN) || (type2 == TCL_NUMBER_DOUBLE)) {
+ result = TCL_ERROR;
+ TRACE(("%.20s %.20s => ILLEGAL 2nd TYPE %s\n", O2S(valuePtr),
+ O2S(value2Ptr), (value2Ptr->typePtr?
+ value2Ptr->typePtr->name : "null")));
+ IllegalExprOperandType(interp, pc, value2Ptr);
+ goto checkForCatch;
+ }
+
+ if ((type1 == TCL_NUMBER_BIG) || (type2 == TCL_NUMBER_BIG)) {
+ mp_int big1, big2, bigResult;
+ mp_int *Pos, *Neg, *Other;
+ int numPos = 0;
+
+ if (Tcl_IsShared(valuePtr)) {
+ Tcl_GetBignumFromObj(NULL, valuePtr, &big1);
+ } else {
+ Tcl_GetBignumAndClearObj(NULL, valuePtr, &big1);
+ }
+ if (Tcl_IsShared(value2Ptr)) {
+ Tcl_GetBignumFromObj(NULL, value2Ptr, &big2);
+ } else {
+ Tcl_GetBignumAndClearObj(NULL, value2Ptr, &big2);
+ }
+
+ if (mp_cmp_d(&big1, 0) != MP_LT) {
+ numPos++;
+ Pos = &big1;
+ if (mp_cmp_d(&big2, 0) != MP_LT) {
+ numPos++;
+ Other = &big2;
+ } else {
+ Neg = &big2;
+ }
+ } else {
+ Neg = &big1;
+ if (mp_cmp_d(&big2, 0) != MP_LT) {
+ numPos++;
+ Pos = &big2;
+ } else {
+ Other = &big2;
+ }
+ }
+ mp_init(&bigResult);
+
+ switch (*pc) {
+ case INST_BITAND:
+ switch (numPos) {
+ case 2:
+ /* Both arguments positive, base case */
+ mp_and(Pos, Other, &bigResult);
+ break;
+ case 1:
+ /* One arg positive; one negative
+ * P & N = P & ~~N = P&~(-N-1) = P & (P ^ (-N-1)) */
+ mp_neg(Neg, Neg);
+ mp_sub_d(Neg, 1, Neg);
+ mp_xor(Pos, Neg, &bigResult);
+ mp_and(Pos, &bigResult, &bigResult);
+ break;
+ case 0:
+ /* Both arguments negative
+ * a & b = ~ (~a | ~b) = -(-a-1|-b-1)-1 */
+ mp_neg(Neg, Neg);
+ mp_sub_d(Neg, 1, Neg);
+ mp_neg(Other, Other);
+ mp_sub_d(Other, 1, Other);
+ mp_or(Neg, Other, &bigResult);
+ mp_neg(&bigResult, &bigResult);
+ mp_sub_d(&bigResult, 1, &bigResult);
+ break;
+ }
+ break;
+
+ case INST_BITOR:
+ switch (numPos) {
+ case 2:
+ /* Both arguments positive, base case */
+ mp_or(Pos, Other, &bigResult);
+ break;
+ case 1:
+ /* One arg positive; one negative
+ * N|P = ~(~N&~P) = ~((-N-1)&~P) = -((-N-1)&((-N-1)^P))-1 */
+ mp_neg(Neg, Neg);
+ mp_sub_d(Neg, 1, Neg);
+ mp_xor(Pos, Neg, &bigResult);
+ mp_and(Neg, &bigResult, &bigResult);
+ mp_neg(&bigResult, &bigResult);
+ mp_sub_d(&bigResult, 1, &bigResult);
+ break;
+ case 0:
+ /* Both arguments negative
+ * a | b = ~ (~a & ~b) = -(-a-1&-b-1)-1 */
+ mp_neg(Neg, Neg);
+ mp_sub_d(Neg, 1, Neg);
+ mp_neg(Other, Other);
+ mp_sub_d(Other, 1, Other);
+ mp_and(Neg, Other, &bigResult);
+ mp_neg(&bigResult, &bigResult);
+ mp_sub_d(&bigResult, 1, &bigResult);
+ break;
+ }
+ break;
+
+ case INST_BITXOR:
+ switch (numPos) {
+ case 2:
+ /* Both arguments positive, base case */
+ mp_xor(Pos, Other, &bigResult);
+ break;
+ case 1:
+ /* One arg positive; one negative
+ * P^N = ~(P^~N) = -(P^(-N-1))-1
+ */
+ mp_neg(Neg, Neg);
+ mp_sub_d(Neg, 1, Neg);
+ mp_xor(Pos, Neg, &bigResult);
+ mp_neg(&bigResult, &bigResult);
+ mp_sub_d(&bigResult, 1, &bigResult);
+ break;
+ case 0:
+ /* Both arguments negative
+ * a ^ b = (~a ^ ~b) = (-a-1^-b-1) */
+ mp_neg(Neg, Neg);
+ mp_sub_d(Neg, 1, Neg);
+ mp_neg(Other, Other);
+ mp_sub_d(Other, 1, Other);
+ mp_xor(Neg, Other, &bigResult);
+ break;
+ }
+ break;
+ }
+
+ mp_clear(&big1);
+ mp_clear(&big2);
+ TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr)));
+ if (Tcl_IsShared(valuePtr)) {
+ objResultPtr = Tcl_NewBignumObj(&bigResult);
+ TRACE(("%s\n", O2S(objResultPtr)));
+ NEXT_INST_F(1, 2, 1);
+ }
+ Tcl_SetBignumObj(valuePtr, &bigResult);
+ TRACE(("%s\n", O2S(valuePtr)));
+ NEXT_INST_F(1, 1, 0);
+ }
+
+#ifndef NO_WIDE_TYPE
+ if ((type1 == TCL_NUMBER_WIDE) || (type2 == TCL_NUMBER_WIDE)) {
+ Tcl_WideInt wResult, w1, w2;
+ TclGetWideIntFromObj(NULL, valuePtr, &w1);
+ TclGetWideIntFromObj(NULL, value2Ptr, &w2);
+
+ switch (*pc) {
+ case INST_BITAND:
+ wResult = w1 & w2;
+ break;
+ case INST_BITOR:
+ wResult = w1 | w2;
+ break;
+ case INST_BITXOR:
+ wResult = w1 ^ w2;
+ }
+
+ TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr)));
+ if (Tcl_IsShared(valuePtr)) {
+ objResultPtr = Tcl_NewWideIntObj(wResult);
+ TRACE(("%s\n", O2S(objResultPtr)));
+ NEXT_INST_F(1, 2, 1);
+ }
+ Tcl_SetWideIntObj(valuePtr, wResult);
+ TRACE(("%s\n", O2S(valuePtr)));
+ NEXT_INST_F(1, 1, 0);
+ }
+#endif
+ {
+ long lResult, l1 = *((CONST long *)ptr1);
+ long l2 = *((CONST long *)ptr2);
+
+ switch (*pc) {
+ case INST_BITAND:
+ lResult = l1 & l2;
+ break;
+ case INST_BITOR:
+ lResult = l1 | l2;
+ break;
+ case INST_BITXOR:
+ lResult = l1 ^ l2;
+ }
+
+ TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr)));
+ if (Tcl_IsShared(valuePtr)) {
+ TclNewLongObj(objResultPtr, lResult);
+ TRACE(("%s\n", O2S(objResultPtr)));
+ NEXT_INST_F(1, 2, 1);
+ }
+ TclSetLongObj(valuePtr, lResult);
+ TRACE(("%s\n", O2S(valuePtr)));
+ NEXT_INST_F(1, 1, 0);
+ }
+ }
+
+#if 0
+ case INST_MOD:
+ {
/*
* Only integers are allowed. We compute value op value2.
*/
@@ -3560,8 +4164,7 @@ TclExecuteByteCode(interp, codePtr)
}
}
- switch (*pc) {
- case INST_MOD:
+ do {
/*
* This code is tricky: C doesn't guarantee much about the
* quotient or remainder, and results with a negative divisor are
@@ -3691,171 +4294,7 @@ TclExecuteByteCode(interp, codePtr)
rem = -rem;
}
iResult = rem;
- break;
- case INST_LSHIFT:
- /*
- * Shifts are never usefully 64-bits wide!
- */
- FORCE_LONG(value2Ptr, i2, w2);
- if (valuePtr->typePtr == &tclWideIntType) {
-#ifdef TCL_COMPILE_DEBUG
- w2 = Tcl_LongAsWide(i2);
-#endif /* TCL_COMPILE_DEBUG */
- wResult = w;
- /*
- * Shift in steps when the shift gets large to prevent
- * annoying compiler/processor bugs. [Bug 868467]
- */
- if (i2 >= 64) {
- wResult = Tcl_LongAsWide(0);
- } else if (i2 > 60) {
- wResult = w << 30;
- wResult <<= 30;
- wResult <<= i2-60;
- } else if (i2 > 30) {
- wResult = w << 30;
- wResult <<= i2-30;
- } else {
- wResult = w << i2;
- }
- doWide = 1;
- break;
- }
- /*
- * Shift in steps when the shift gets large to prevent annoying
- * compiler/processor bugs. [Bug 868467]
- */
- if (i2 >= 64) {
- iResult = 0;
- } else if (i2 > 60) {
- iResult = i << 30;
- iResult <<= 30;
- iResult <<= i2-60;
- } else if (i2 > 30) {
- iResult = i << 30;
- iResult <<= i2-30;
- } else {
- iResult = i << i2;
- }
- break;
- case INST_RSHIFT:
- /*
- * The following code is a bit tricky: it ensures that right
- * shifts propagate the sign bit even on machines where ">>" won't
- * do it by default.
- */
- /*
- * Shifts are never usefully 64-bits wide!
- */
- FORCE_LONG(value2Ptr, i2, w2);
- if (valuePtr->typePtr == &tclWideIntType) {
-#ifdef TCL_COMPILE_DEBUG
- w2 = Tcl_LongAsWide(i2);
-#endif /* TCL_COMPILE_DEBUG */
- if (w < 0) {
- wResult = ~w;
- } else {
- wResult = w;
- }
- /*
- * Shift in steps when the shift gets large to prevent
- * annoying compiler/processor bugs. [Bug 868467]
- */
- if (i2 >= 64) {
- wResult = Tcl_LongAsWide(0);
- } else if (i2 > 60) {
- wResult >>= 30;
- wResult >>= 30;
- wResult >>= i2-60;
- } else if (i2 > 30) {
- wResult >>= 30;
- wResult >>= i2-30;
- } else {
- wResult >>= i2;
- }
- if (w < 0) {
- wResult = ~wResult;
- }
- doWide = 1;
- break;
- }
- if (i < 0) {
- iResult = ~i;
- } else {
- iResult = i;
- }
- /*
- * Shift in steps when the shift gets large to prevent annoying
- * compiler/processor bugs. [Bug 868467]
- */
- if (i2 >= 64) {
- iResult = 0;
- } else if (i2 > 60) {
- iResult >>= 30;
- iResult >>= 30;
- iResult >>= i2-60;
- } else if (i2 > 30) {
- iResult >>= 30;
- iResult >>= i2-30;
- } else {
- iResult >>= i2;
- }
- if (i < 0) {
- iResult = ~iResult;
- }
- break;
- case INST_BITOR:
- if (valuePtr->typePtr == &tclWideIntType
- || value2Ptr->typePtr == &tclWideIntType) {
- /*
- * Promote to wide
- */
- if (valuePtr->typePtr == &tclIntType) {
- w = Tcl_LongAsWide(i);
- } else if (value2Ptr->typePtr == &tclIntType) {
- w2 = Tcl_LongAsWide(i2);
- }
- wResult = w | w2;
- doWide = 1;
- break;
- }
- iResult = i | i2;
- break;
- case INST_BITXOR:
- if (valuePtr->typePtr == &tclWideIntType
- || value2Ptr->typePtr == &tclWideIntType) {
- /*
- * Promote to wide
- */
- if (valuePtr->typePtr == &tclIntType) {
- w = Tcl_LongAsWide(i);
- } else if (value2Ptr->typePtr == &tclIntType) {
- w2 = Tcl_LongAsWide(i2);
- }
- wResult = w ^ w2;
- doWide = 1;
- break;
- }
- iResult = i ^ i2;
- break;
- case INST_BITAND:
- if (valuePtr->typePtr == &tclWideIntType
- || value2Ptr->typePtr == &tclWideIntType) {
- /*
- * Promote to wide
- */
- if (valuePtr->typePtr == &tclIntType) {
- w = Tcl_LongAsWide(i);
- } else if (value2Ptr->typePtr == &tclIntType) {
- w2 = Tcl_LongAsWide(i2);
- }
- wResult = w & w2;
- doWide = 1;
- break;
- }
- iResult = i & i2;
- break;
- }
+ } while (0);
/*
* Reuse the valuePtr object already on stack if possible.
@@ -3881,27 +4320,284 @@ TclExecuteByteCode(interp, codePtr)
NEXT_INST_F(1, 1, 0);
}
}
+#endif
case INST_ADD:
case INST_SUB:
- case INST_MULT:
case INST_DIV:
+ case INST_MULT: {
+ ClientData ptr1, ptr2;
+ int type1, type2;
+ Tcl_Obj *value2Ptr = *tosPtr;
+ Tcl_Obj *valuePtr = *(tosPtr - 1);
+
+ result = GetNumberFromObj(NULL, valuePtr, &ptr1, &type1);
+ if ((result != TCL_OK)
+#ifndef ACCEPT_NAN
+ || (type1 == TCL_NUMBER_NAN)
+#endif
+ ) {
+ result = TCL_ERROR;
+ TRACE(("%.20s %.20s => ILLEGAL 1st TYPE %s\n",
+ O2S(value2Ptr), O2S(valuePtr),
+ (valuePtr->typePtr? valuePtr->typePtr->name: "null")));
+ IllegalExprOperandType(interp, pc, valuePtr);
+ goto checkForCatch;
+ }
+
+#ifdef ACCEPT_NAN
+ if (type1 == TCL_NUMBER_NAN) {
+ /* NaN first argument -> result is also NaN */
+ NEXT_INST_F(1, 1, 0);
+ }
+#endif
+
+ result = GetNumberFromObj(NULL, value2Ptr, &ptr2, &type2);
+ if ((result != TCL_OK)
+#ifndef ACCEPT_NAN
+ || (type2 == TCL_NUMBER_NAN)
+#endif
+ ) {
+ result = TCL_ERROR;
+ TRACE(("%.20s %.20s => ILLEGAL 2nd TYPE %s\n",
+ O2S(value2Ptr), O2S(valuePtr),
+ (value2Ptr->typePtr? value2Ptr->typePtr->name: "null")));
+ IllegalExprOperandType(interp, pc, value2Ptr);
+ goto checkForCatch;
+ }
+
+#ifdef ACCEPT_NAN
+ if (type2 == TCL_NUMBER_NAN) {
+ /* NaN second argument -> result is also NaN */
+ objResultPtr = value2Ptr;
+ NEXT_INST_F(1, 2, 1);
+ }
+#endif
+
+ if ((type1 == TCL_NUMBER_DOUBLE) || (type2 == TCL_NUMBER_DOUBLE)) {
+ /* At least one of the values is floating-point, so perform
+ * floating point calculations */
+ double d1, d2, dResult;
+ Tcl_GetDoubleFromObj(NULL, valuePtr, &d1);
+ Tcl_GetDoubleFromObj(NULL, value2Ptr, &d2);
+
+ switch (*pc) {
+ case INST_ADD:
+ dResult = d1 + d2;
+ break;
+ case INST_SUB:
+ dResult = d1 - d2;
+ break;
+ case INST_MULT:
+ dResult = d1 * d2;
+ break;
+ case INST_DIV:
+#ifndef IEEE_FLOATING_POINT
+ if (d2 == 0.0) {
+ TRACE(("%.6g %.6g => DIVIDE BY ZERO\n", d1, d2));
+ goto divideByZero;
+ }
+#endif
+ /*
+ * We presume that we are running with zero-divide unmasked if
+ * we're on an IEEE box. Otherwise, this statement might cause
+ * demons to fly out our noses.
+ */
+ dResult = d1 / d2;
+ break;
+ }
+
+#ifndef ACCEPT_NAN
+ /*
+ * Check now for IEEE floating-point error.
+ */
+
+ if (TclIsNaN(dResult)) {
+ TRACE(("%.20s %.20s => IEEE FLOATING PT ERROR\n",
+ O2S(valuePtr), O2S(value2Ptr)));
+ TclExprFloatError(interp, dResult);
+ result = TCL_ERROR;
+ goto checkForCatch;
+ }
+#endif
+ TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr)));
+ if (Tcl_IsShared(valuePtr)) {
+ TclNewDoubleObj(objResultPtr, dResult);
+ TRACE(("%s\n", O2S(objResultPtr)));
+ NEXT_INST_F(1, 2, 1);
+ }
+ TclSetDoubleObj(valuePtr, dResult);
+ TRACE(("%s\n", O2S(valuePtr)));
+ NEXT_INST_F(1, 1, 0);
+ }
+
+ if ((*pc == INST_MULT) && (sizeof(Tcl_WideInt) >= 2*sizeof(long))
+ && (type1 == TCL_NUMBER_LONG) && (type2 == TCL_NUMBER_LONG)) {
+ Tcl_WideInt w1, w2, wResult;
+ TclGetWideIntFromObj(NULL, valuePtr, &w1);
+ TclGetWideIntFromObj(NULL, value2Ptr, &w2);
+
+ wResult = w1 * w2;
+
+ TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr)));
+ if (Tcl_IsShared(valuePtr)) {
+ objResultPtr = Tcl_NewWideIntObj(wResult);
+ TRACE(("%s\n", O2S(objResultPtr)));
+ NEXT_INST_F(1, 2, 1);
+ }
+ Tcl_SetWideIntObj(valuePtr, wResult);
+ TRACE(("%s\n", O2S(valuePtr)));
+ NEXT_INST_F(1, 1, 0);
+ }
+
+ if ((*pc != INST_MULT)
+ && (type1 != TCL_NUMBER_BIG) && (type2 != TCL_NUMBER_BIG)) {
+ Tcl_WideInt w1, w2, wResult;
+ TclGetWideIntFromObj(NULL, valuePtr, &w1);
+ TclGetWideIntFromObj(NULL, value2Ptr, &w2);
+
+ switch (*pc) {
+ case INST_ADD:
+ wResult = w1 + w2;
+#ifndef NO_WIDE_TYPE
+ if ((type1 == TCL_NUMBER_WIDE) || (type2 == TCL_NUMBER_WIDE))
+#endif
+ {
+ /* Check for overflow */
+ if (((w1 < 0) && (w2 < 0) && (wResult > 0))
+ || ((w1 > 0) && (w2 > 0) && (wResult < 0))) {
+ goto overflow;
+ }
+ }
+ break;
+
+ case INST_SUB:
+ wResult = w1 - w2;
+#ifndef NO_WIDE_TYPE
+ if ((type1 == TCL_NUMBER_WIDE) || (type2 == TCL_NUMBER_WIDE))
+#endif
+ {
+ /* Must check for overflow */
+ if (((w1 < 0) && (w2 > 0) && (wResult > 0))
+ || ((w1 > 0) && (w2 < 0) && (wResult < 0))) {
+ goto overflow;
+ }
+ }
+ break;
+
+ case INST_DIV:
+ if (w2 == 0) {
+ TRACE(("%s %s => DIVIDE BY ZERO\n",
+ O2S(valuePtr), O2S(value2Ptr)));
+ goto divideByZero;
+ }
+
+ /* Need a bignum to represent (LLONG_MIN / -1) */
+ if ((w1 == LLONG_MIN) && (w2 == -1)) {
+ goto overflow;
+ }
+ wResult = w1 / w2;
+
+ /* Force Tcl's integer division rules */
+ /* TODO: examine for logic simplification */
+ if (((wResult < 0) || ((wResult == 0) &&
+ ((w1 < 0 && w2 > 0) || (w1 > 0 && w2 < 0)))) &&
+ ((wResult * w2) != w1)) {
+ wResult -= 1;
+ }
+ break;
+ }
+
+ TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr)));
+ if (Tcl_IsShared(valuePtr)) {
+ objResultPtr = Tcl_NewWideIntObj(wResult);
+ TRACE(("%s\n", O2S(objResultPtr)));
+ NEXT_INST_F(1, 2, 1);
+ }
+ Tcl_SetWideIntObj(valuePtr, wResult);
+ TRACE(("%s\n", O2S(valuePtr)));
+ NEXT_INST_F(1, 1, 0);
+ }
+
+ overflow:
+ {
+ mp_int big1, big2, bigResult, bigRemainder;
+ TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr)));
+ if (Tcl_IsShared(valuePtr)) {
+ Tcl_GetBignumFromObj(NULL, valuePtr, &big1);
+ } else {
+ Tcl_GetBignumAndClearObj(NULL, valuePtr, &big1);
+ }
+ if (Tcl_IsShared(value2Ptr)) {
+ Tcl_GetBignumFromObj(NULL, value2Ptr, &big2);
+ } else {
+ Tcl_GetBignumAndClearObj(NULL, value2Ptr, &big2);
+ }
+ mp_init(&bigResult);
+ switch (*pc) {
+ case INST_ADD:
+ mp_add(&big1, &big2, &bigResult);
+ break;
+ case INST_SUB:
+ mp_sub(&big1, &big2, &bigResult);
+ break;
+ case INST_MULT:
+ mp_mul(&big1, &big2, &bigResult);
+ break;
+ case INST_DIV:
+ if (mp_iszero(&big2)) {
+ TRACE(("%s %s => DIVIDE BY ZERO\n", O2S(valuePtr),
+ O2S(value2Ptr)));
+ mp_clear(&big1);
+ mp_clear(&big2);
+ goto divideByZero;
+ }
+ mp_init(&bigRemainder);
+ mp_div(&big1, &big2, &bigResult, &bigRemainder);
+ /* TODO: internals intrusion */
+ if (!mp_iszero(&bigRemainder)
+ && (bigRemainder.sign != big2.sign)) {
+ /* Convert to Tcl's integer division rules */
+ mp_sub_d(&bigResult, 1, &bigResult);
+ mp_add(&bigRemainder, &big2, &bigRemainder);
+ }
+ if (*pc == INST_MOD) {
+ mp_copy(&bigRemainder, &bigResult);
+ }
+ mp_clear(&bigRemainder);
+ break;
+ }
+ mp_clear(&big1);
+ mp_clear(&big2);
+ if (Tcl_IsShared(valuePtr)) {
+ objResultPtr = Tcl_NewBignumObj(&bigResult);
+ TRACE(("%s\n", O2S(objResultPtr)));
+ NEXT_INST_F(1, 2, 1);
+ }
+ Tcl_SetBignumObj(valuePtr, &bigResult);
+ TRACE(("%s\n", O2S(valuePtr)));
+ NEXT_INST_F(1, 1, 0);
+ }
+ }
+
+ case INST_MOD:
case INST_EXPON: {
/*
* Operands must be numeric and ints get converted to floats if
* necessary. We compute value op value2.
*/
+ double d1, d2;
+ double dResult = 0.0; /* Init. avoids compiler warning. */
+ Tcl_Obj *valuePtr,*value2Ptr;
+#if 0
Tcl_ObjType *t1Ptr, *t2Ptr;
long i = 0, i2 = 0, quot; /* Init. avoids compiler warning. */
- double d1, d2;
long iResult = 0; /* Init. avoids compiler warning. */
- double dResult = 0.0; /* Init. avoids compiler warning. */
int doDouble = 0; /* 1 if doing floating arithmetic */
Tcl_WideInt w, w2, wquot;
Tcl_WideInt wResult = W0; /* Init. avoids compiler warning. */
int doWide = 0; /* 1 if doing wide arithmetic. */
- Tcl_Obj *valuePtr,*value2Ptr;
int length;
value2Ptr = *tosPtr;
@@ -3994,20 +4690,6 @@ TclExecuteByteCode(interp, codePtr)
case INST_MULT:
dResult = d1 * d2;
break;
- case INST_DIV:
-#ifndef IEEE_FLOATING_POINT
- if (d2 == 0.0) {
- TRACE(("%.6g %.6g => DIVIDE BY ZERO\n", d1, d2));
- goto divideByZero;
- }
-#endif
- /*
- * We presume that we are running with zero-divide unmasked if
- * we're on an IEEE box. Otherwise, this statement might cause
- * demons to fly out our noses.
- */
- dResult = d1 / d2;
- break;
case INST_EXPON:
if (d1==0.0 && d2<0.0) {
TRACE(("%.6g %.6g => EXPONENT OF ZERO\n", d1, d2));
@@ -4175,261 +4857,345 @@ TclExecuteByteCode(interp, codePtr)
}
NEXT_INST_F(1, 1, 0);
}
- }
-
- case INST_UPLUS: {
- /*
- * Operand must be numeric.
- */
-
- double d;
- Tcl_ObjType *tPtr;
- Tcl_Obj *valuePtr;
-
- valuePtr = *tosPtr;
- tPtr = valuePtr->typePtr;
- if (IS_INTEGER_TYPE(tPtr)
- || ((tPtr == &tclDoubleType) && (valuePtr->bytes == NULL))) {
- /*
- * We already have a numeric internal rep, either some kind of
- * integer, or a "pure" double. (Need "pure" so that we know the
- * string rep of the double would not prefer to be interpreted as
- * an integer.)
- */
- } else {
- /*
- * Otherwise, we need to generate a numeric internal rep. from
- * the string rep.
- */
- int length;
- long i; /* Set but never used, needed in GET_WIDE_OR_INT */
- Tcl_WideInt w;
- char *s = Tcl_GetStringFromObj(valuePtr, &length);
-
- if (TclLooksLikeInt(s, length)) {
- GET_WIDE_OR_INT(result, valuePtr, i, w);
- } else {
- result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL, valuePtr, &d);
- }
- if (result != TCL_OK) {
- TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n",
- s, (tPtr? tPtr->name : "null")));
- IllegalExprOperandType(interp, pc, valuePtr);
- goto checkForCatch;
+#else
+ value2Ptr = *tosPtr;
+ 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);
}
- tPtr = valuePtr->typePtr;
+#endif
+ TRACE(("%.20s %.20s => ILLEGAL 1st TYPE %s\n",
+ O2S(value2Ptr), O2S(valuePtr),
+ (valuePtr->typePtr? valuePtr->typePtr->name: "null")));
+ IllegalExprOperandType(interp, pc, valuePtr);
+ goto checkForCatch;
}
-
- /*
- * Ensure that the operand's string rep is the same as the formatted
- * version of its internal rep. This makes sure that "expr +000123"
- * yields "83", not "000123". We implement this by _discarding_ the
- * string rep since we know it will be regenerated, if needed later,
- * by formatting the internal rep's value.
- */
-
- if (Tcl_IsShared(valuePtr)) {
- if (tPtr == &tclIntType) {
- TclNewLongObj(objResultPtr, valuePtr->internalRep.longValue);
- } else if (tPtr == &tclWideIntType) {
- Tcl_WideInt w;
-
- TclGetWide(w,valuePtr);
- TclNewWideIntObj(objResultPtr, w);
- } else {
- TclNewDoubleObj(objResultPtr, valuePtr->internalRep.doubleValue);
+ 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);
}
- TRACE_WITH_OBJ(("%s => ", O2S(objResultPtr)), objResultPtr);
- NEXT_INST_F(1, 1, 1);
- } else {
- TclInvalidateStringRep(valuePtr);
- TRACE_WITH_OBJ(("%s => ", O2S(valuePtr)), valuePtr);
- NEXT_INST_F(1, 0, 0);
+#endif
+ TRACE(("%.20s %.20s => ILLEGAL 2nd TYPE %s\n",
+ O2S(value2Ptr), O2S(valuePtr),
+ (value2Ptr->typePtr? value2Ptr->typePtr->name: "null")));
+ IllegalExprOperandType(interp, pc, value2Ptr);
+ goto checkForCatch;
}
- }
-
- case INST_UMINUS:
- case INST_LNOT: {
- /*
- * The operand must be numeric or a boolean string as accepted by
- * Tcl_GetBooleanFromObj(). If the operand object is unshared modify
- * it directly, otherwise create a copy to modify: this is "copy on
- * write". Free any old string representation since it is now
- * invalid.
- */
-
- double d;
- int boolvar;
- long i;
- int negate_value = 1;
- Tcl_WideInt w;
- Tcl_ObjType *tPtr;
- Tcl_Obj *valuePtr;
-
- valuePtr = *tosPtr;
- tPtr = valuePtr->typePtr;
- if (IS_INTEGER_TYPE(tPtr)
- || ((tPtr == &tclDoubleType) && (valuePtr->bytes == NULL))) {
- /*
- * We already have a numeric internal rep, either some kind of
- * integer, or a "pure" double. (Need "pure" so that we know the
- * string rep of the double would not prefer to be interpreted as
- * an integer.)
- */
- } else {
+ if (valuePtr->typePtr == &tclDoubleType
+ || value2Ptr->typePtr == &tclDoubleType) {
+ /* At least one of the values is floating-point, so perform
+ * floating point calculations */
+ switch (*pc) {
+ case INST_EXPON:
+ if (d1==0.0 && d2<0.0) {
+ TRACE(("%.6g %.6g => EXPONENT OF ZERO\n", d1, d2));
+ goto exponOfZero;
+ }
+ dResult = pow(d1, d2);
+ break;
+ case INST_MOD:
+ if (valuePtr->typePtr == &tclDoubleType) {
+ TRACE(("%.20s %.20s => ILLEGAL 1st TYPE %s\n",
+ O2S(value2Ptr), O2S(valuePtr), (valuePtr->typePtr?
+ valuePtr->typePtr->name: "null")));
+ IllegalExprOperandType(interp, pc, valuePtr);
+ } else {
+ TRACE(("%.20s %.20s => ILLEGAL 2nd TYPE %s\n",
+ O2S(value2Ptr), O2S(valuePtr), (value2Ptr->typePtr?
+ value2Ptr->typePtr->name: "null")));
+ IllegalExprOperandType(interp, pc, value2Ptr);
+ }
+ result = TCL_ERROR;
+ goto checkForCatch;
+ }
+#ifndef ACCEPT_NAN
/*
- * Otherwise, we need to generate a numeric internal rep. from
- * the string rep.
+ * Check now for IEEE floating-point error.
*/
- int length;
- char *s = Tcl_GetStringFromObj(valuePtr, &length);
- if (TclLooksLikeInt(s, length)) {
- GET_WIDE_OR_INT(result, valuePtr, i, w);
-
- /*
- * An integer was parsed. If parsing a literal that is the
- * smallest long value, then it would have been promoted to a
- * wide since it would not fit in a long type without the
- * leading '-'. Convert back to the smallest possible long.
- */
- if ((result == TCL_OK) &&
- (*pc == INST_UMINUS) &&
- (valuePtr->typePtr == &tclWideIntType) &&
- (w == -Tcl_LongAsWide(LONG_MIN))) {
- valuePtr->typePtr = &tclIntType;
- valuePtr->internalRep.longValue = LONG_MIN;
- negate_value = 0;
- }
- } else {
- result = Tcl_GetDoubleFromObj(NULL, valuePtr, &d);
- }
- if (result == TCL_ERROR && *pc == INST_LNOT) {
- result = Tcl_GetBooleanFromObj(NULL, valuePtr, &boolvar);
- i = (long)boolvar; /* i is long, not int! */
- }
- if (result != TCL_OK) {
- TRACE(("\"%.20s\" => ILLEGAL TYPE %s\n", s,
- (tPtr? tPtr->name : "null")));
- IllegalExprOperandType(interp, pc, valuePtr);
+ if (TclIsNaN(dResult)) {
+ TRACE(("%.20s %.20s => IEEE FLOATING PT ERROR\n",
+ O2S(valuePtr), O2S(value2Ptr)));
+ TclExprFloatError(interp, dResult);
+ result = TCL_ERROR;
goto checkForCatch;
}
- tPtr = valuePtr->typePtr;
- }
-
- if (*pc == INST_UMINUS) {
+#endif
if (Tcl_IsShared(valuePtr)) {
- /*
- * Create a new object.
- */
- if (tPtr == &tclIntType) {
- i = valuePtr->internalRep.longValue;
- if (negate_value) {
- i = -i;
+ TclNewDoubleObj(objResultPtr, dResult);
+ NEXT_INST_F(1, 2, 1);
+ }
+ TclSetDoubleObj(valuePtr, dResult);
+ NEXT_INST_F(1, 1, 0);
+ } else {
+ /* Both values are some kind of integer */
+ /* TODO: optimize use of narrower native integers */
+ mp_int big1, big2, bigResult, bigRemainder;
+ Tcl_GetBignumFromObj(NULL, valuePtr, &big1);
+ Tcl_GetBignumFromObj(NULL, value2Ptr, &big2);
+ mp_init(&bigResult);
+ switch (*pc) {
+ case INST_MOD:
+ if (mp_iszero(&big2)) {
+ TRACE(("%s %s => DIVIDE BY ZERO\n", O2S(valuePtr),
+ O2S(value2Ptr)));
+ mp_clear(&big1);
+ mp_clear(&big2);
+ goto divideByZero;
+ }
+ mp_init(&bigRemainder);
+ mp_div(&big1, &big2, &bigResult, &bigRemainder);
+ if (!mp_iszero(&bigRemainder)
+ && (bigRemainder.sign != big2.sign)) {
+ /* Convert to Tcl's integer division rules */
+ mp_sub_d(&bigResult, 1, &bigResult);
+ mp_add(&bigRemainder, &big2, &bigRemainder);
+ }
+ if (*pc == INST_MOD) {
+ mp_copy(&bigRemainder, &bigResult);
+ }
+ mp_clear(&bigRemainder);
+ break;
+ case INST_EXPON:
+ if (mp_iszero(&big2)) {
+ /* Anything to the zero power is 1 */
+ mp_clear(&big1);
+ mp_clear(&big2);
+ objResultPtr = eePtr->constants[1];
+ NEXT_INST_F(1, 2, 1);
+ }
+ if (mp_iszero(&big1)) {
+ if (mp_cmp_d(&big2, 0) == MP_LT) {
+ TRACE(("%s %s => EXPONENT OF ZERO\n", O2S(valuePtr),
+ O2S(value2Ptr)));
+ mp_clear(&big1);
+ mp_clear(&big2);
+ goto exponOfZero;
}
- TclNewLongObj(objResultPtr, i);
- TRACE_WITH_OBJ(("%ld => ", i), objResultPtr);
- } else if (tPtr == &tclWideIntType) {
- TclGetWide(w,valuePtr);
- TclNewWideIntObj(objResultPtr, -w);
- TRACE_WITH_OBJ((LLD" => ", w), objResultPtr);
- } else {
- d = valuePtr->internalRep.doubleValue;
- TclNewDoubleObj(objResultPtr, -d);
- TRACE_WITH_OBJ(("%.6g => ", d), objResultPtr);
+ mp_clear(&big1);
+ mp_clear(&big2);
+ objResultPtr = eePtr->constants[0];
+ NEXT_INST_F(1, 2, 1);
}
- NEXT_INST_F(1, 1, 1);
- } else {
- /*
- * valuePtr is unshared. Modify it directly.
- */
- if (tPtr == &tclIntType) {
- i = valuePtr->internalRep.longValue;
- if (negate_value) {
- i = -i;
+ if (mp_cmp_d(&big2, 0) == MP_LT) {
+ switch (mp_cmp_d(&big1, 1)) {
+ case MP_GT:
+ objResultPtr = eePtr->constants[0];
+ break;
+ case MP_EQ:
+ objResultPtr = eePtr->constants[1];
+ break;
+ case MP_LT:
+ mp_add_d(&big1, 1, &big1);
+ if (mp_cmp_d(&big1, 0) == MP_LT) {
+ objResultPtr = eePtr->constants[0];
+ break;
+ }
+ mp_mod_2d(&big2, 1, &big2);
+ if (mp_iszero(&big2)) {
+ objResultPtr = eePtr->constants[1];
+ } else {
+ TclNewIntObj(objResultPtr, -1);
+ }
}
- TclSetLongObj(valuePtr, i);
- TRACE_WITH_OBJ(("%ld => ", i), valuePtr);
- } else if (tPtr == &tclWideIntType) {
- TclGetWide(w,valuePtr);
- TclSetWideIntObj(valuePtr, -w);
- TRACE_WITH_OBJ((LLD" => ", w), valuePtr);
- } else {
- d = valuePtr->internalRep.doubleValue;
- TclSetDoubleObj(valuePtr, -d);
- TRACE_WITH_OBJ(("%.6g => ", d), valuePtr);
+ mp_clear(&big1);
+ mp_clear(&big2);
+ NEXT_INST_F(1, 2, 1);
}
- NEXT_INST_F(1, 0, 0);
+ if (big2.used > 1) {
+ Tcl_SetObjResult(interp,
+ Tcl_NewStringObj("exponent too large", -1));
+ mp_clear(&big1);
+ mp_clear(&big2);
+ goto checkForCatch;
+ }
+ mp_expt_d(&big1, big2.dp[0], &bigResult);
+ break;
}
- } else { /* *pc == INST_UMINUS */
- if ((tPtr == &tclIntType) || (tPtr == &tclBooleanType)) {
- i = !valuePtr->internalRep.longValue;
- TRACE_WITH_OBJ(("%ld => ", i), objResultPtr);
- } else if (tPtr == &tclWideIntType) {
- TclGetWide(w,valuePtr);
- i = (w == W0);
- TRACE_WITH_OBJ((LLD" => ", w), objResultPtr);
- } else {
- i = (valuePtr->internalRep.doubleValue == 0.0);
- TRACE_WITH_OBJ(("%.6g => ", d), objResultPtr);
+ mp_clear(&big1);
+ mp_clear(&big2);
+ TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr)));
+ if (Tcl_IsShared(valuePtr)) {
+ objResultPtr = Tcl_NewBignumObj(&bigResult);
+ TRACE(("%s\n", O2S(objResultPtr)));
+ NEXT_INST_F(1, 2, 1);
}
- objResultPtr = eePtr->constants[i];
- NEXT_INST_F(1, 1, 1);
+ Tcl_SetBignumObj(valuePtr, &bigResult);
+ TRACE(("%s\n", O2S(valuePtr)));
+ NEXT_INST_F(1, 1, 0);
}
+#endif
}
- case INST_BITNOT: {
- /*
- * The operand must be an integer. If the operand object is unshared
- * modify it directly, otherwise modify a copy. Free any old string
- * representation since it is now invalid.
- */
+ case INST_LNOT: {
+ int b;
+ Tcl_Obj *valuePtr = *tosPtr;
- Tcl_ObjType *tPtr;
- Tcl_Obj *valuePtr;
- Tcl_WideInt w;
- long i;
+ /* TODO - check claim that taking address of b harms performance */
+ /* TODO - consider optimization search for eePtr->constants */
+ result = TclGetBooleanFromObj(NULL, valuePtr, &b);
+ if (result != TCL_OK) {
+ TRACE(("\"%.20s\" => ILLEGAL TYPE %s\n", O2S(valuePtr),
+ (valuePtr->typePtr? valuePtr->typePtr->name : "null")));
+ IllegalExprOperandType(interp, pc, valuePtr);
+ goto checkForCatch;
+ }
+ /* TODO: Consider peephole opt. */
+ objResultPtr = eePtr->constants[!b];
+ NEXT_INST_F(1, 1, 1);
+ }
- valuePtr = *tosPtr;
- tPtr = valuePtr->typePtr;
- if (!IS_INTEGER_TYPE(tPtr)) {
- REQUIRE_WIDE_OR_INT(result, valuePtr, i, w);
- if (result != TCL_OK) { /* try to convert to double */
- TRACE(("\"%.20s\" => ILLEGAL TYPE %s\n",
- O2S(valuePtr), (tPtr? tPtr->name : "null")));
- IllegalExprOperandType(interp, pc, valuePtr);
- goto checkForCatch;
+ case INST_BITNOT: {
+ mp_int big;
+ ClientData ptr;
+ int type;
+ Tcl_Obj *valuePtr = *tosPtr;
+
+ result = GetNumberFromObj(NULL, valuePtr, &ptr, &type);
+ if ((result != TCL_OK)
+ || (type == TCL_NUMBER_NAN) || (type == TCL_NUMBER_DOUBLE)) {
+ /* ... ~$NonInteger => raise an error */
+ result = TCL_ERROR;
+ TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(valuePtr),
+ (valuePtr->typePtr? valuePtr->typePtr->name : "null")));
+ IllegalExprOperandType(interp, pc, valuePtr);
+ goto checkForCatch;
+ }
+ if (type == TCL_NUMBER_LONG) {
+ long l = *((CONST long *)ptr);
+ if (Tcl_IsShared(valuePtr)) {
+ TclNewLongObj(objResultPtr, ~l);
+ NEXT_INST_F(1, 1, 1);
}
+ TclSetLongObj(valuePtr, ~l);
+ NEXT_INST_F(1, 0, 0);
}
-
- if (valuePtr->typePtr == &tclWideIntType) {
- TclGetWide(w,valuePtr);
+#ifndef NO_WIDE_TYPE
+ if (type == TCL_NUMBER_LONG) {
+ Tcl_WideInt w = *((CONST Tcl_WideInt *)ptr);
if (Tcl_IsShared(valuePtr)) {
- TclNewWideIntObj(objResultPtr, ~w);
- TRACE(("0x%llx => (%llu)\n", w, ~w));
+ objResultPtr = Tcl_NewWideIntObj(~w);
NEXT_INST_F(1, 1, 1);
- } else {
- /*
- * valuePtr is unshared. Modify it directly.
- */
- TclSetWideIntObj(valuePtr, ~w);
- TRACE(("0x%llx => (%llu)\n", w, ~w));
- NEXT_INST_F(1, 0, 0);
}
+ Tcl_SetWideIntObj(valuePtr, ~w);
+ NEXT_INST_F(1, 0, 0);
+ }
+#endif
+ if (Tcl_IsShared(valuePtr)) {
+ Tcl_GetBignumFromObj(NULL, valuePtr, &big);
} else {
- i = valuePtr->internalRep.longValue;
+ Tcl_GetBignumAndClearObj(NULL, valuePtr, &big);
+ }
+ /* ~a = - a - 1 */
+ mp_neg(&big, &big);
+ mp_sub_d(&big, 1, &big);
+ if (Tcl_IsShared(valuePtr)) {
+ objResultPtr = Tcl_NewBignumObj(&big);
+ NEXT_INST_F(1, 1, 1);
+ }
+ Tcl_SetBignumObj(valuePtr, &big);
+ NEXT_INST_F(1, 0, 0);
+ }
+
+ case INST_UMINUS: {
+ ClientData ptr;
+ int type;
+ Tcl_Obj *valuePtr = *tosPtr;
+
+ result = GetNumberFromObj(NULL, valuePtr, &ptr, &type);
+ if ((result != TCL_OK)
+#ifndef ACCEPT_NAN
+ || (type == TCL_NUMBER_NAN)
+#endif
+ ) {
+ result = TCL_ERROR;
+ TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(valuePtr),
+ (valuePtr->typePtr? valuePtr->typePtr->name : "null")));
+ IllegalExprOperandType(interp, pc, valuePtr);
+ goto checkForCatch;
+ }
+ switch (type) {
+ case TCL_NUMBER_DOUBLE: {
+ double d;
if (Tcl_IsShared(valuePtr)) {
- TclNewLongObj(objResultPtr, ~i);
- TRACE(("0x%lx => (%lu)\n", i, ~i));
+ TclNewDoubleObj(objResultPtr, -(*((CONST double *)ptr)));
NEXT_INST_F(1, 1, 1);
+ }
+ d = *((CONST double *)ptr);
+ TclSetDoubleObj(valuePtr, -d);
+ NEXT_INST_F(1, 0, 0);
+ }
+ case TCL_NUMBER_LONG: {
+ long l = *((CONST long *)ptr);
+ if (l != LONG_MIN) {
+ if (Tcl_IsShared(valuePtr)) {
+ TclNewLongObj(objResultPtr, -l);
+ NEXT_INST_F(1, 1, 1);
+ }
+ TclSetLongObj(valuePtr, -l);
+ NEXT_INST_F(1, 0, 0);
+ }
+ /* FALLTHROUGH */
+ }
+#ifndef NO_WIDE_TYPE
+ case TCL_NUMBER_WIDE: {
+ Tcl_WideInt w;
+ if (type == TCL_NUMBER_LONG) {
+ w = (Tcl_WideInt)(*((CONST long *)ptr));
} else {
- /*
- * valuePtr is unshared. Modify it directly.
- */
- TclSetLongObj(valuePtr, ~i);
- TRACE(("0x%lx => (%lu)\n", i, ~i));
+ w = *((CONST Tcl_WideInt *)ptr);
+ }
+ if (w != LLONG_MIN) {
+ if (Tcl_IsShared(valuePtr)) {
+ objResultPtr = Tcl_NewWideIntObj(-w);
+ NEXT_INST_F(1, 1, 1);
+ }
+ Tcl_SetWideIntObj(valuePtr, -w);
NEXT_INST_F(1, 0, 0);
}
+ /* FALLTHROUGH */
+ }
+#endif
+ case TCL_NUMBER_BIG: {
+ mp_int big;
+ switch (type) {
+#ifdef NO_WIDE_TYPE
+ case TCL_NUMBER_LONG:
+ TclBNInitBignumFromLong(&big, *((CONST long *)ptr));
+ break;
+#else
+ case TCL_NUMBER_WIDE:
+ TclBNInitBignumFromWideInt(&big, *((CONST Tcl_WideInt*)ptr));
+ break;
+#endif
+ case TCL_NUMBER_BIG:
+ if (Tcl_IsShared(valuePtr)) {
+ Tcl_GetBignumFromObj(NULL, valuePtr, &big);
+ } else {
+ Tcl_GetBignumAndClearObj(NULL, valuePtr, &big);
+ }
+ }
+ mp_neg(&big, &big);
+ if (Tcl_IsShared(valuePtr)) {
+ objResultPtr = Tcl_NewBignumObj(&big);
+ NEXT_INST_F(1, 1, 1);
+ }
+ Tcl_SetBignumObj(valuePtr, &big);
+ NEXT_INST_F(1, 0, 0);
+ }
+ case TCL_NUMBER_NAN:
+ /* -NaN => NaN */
+ NEXT_INST_F(1, 0, 0);
}
}
@@ -4441,109 +5207,78 @@ TclExecuteByteCode(interp, codePtr)
Tcl_Panic("TclExecuteByteCode: obsolete INST_CALL_FUNC1 found");
}
+ case INST_UPLUS:
case INST_TRY_CVT_TO_NUMERIC: {
/*
- * Try to convert the topmost stack object to an int or double object.
- * This is done in order to support Tcl's policy of interpreting
- * operands if at all possible as first integers, else floating-point
- * numbers.
+ * Try to convert the topmost stack object to numeric object.
+ * This is done in order to support [expr]'s policy of interpreting
+ * operands if at all possible as numbers first, then strings.
*/
- double d;
- char *s;
- Tcl_ObjType *tPtr;
- int converted, needNew, length;
- Tcl_Obj *valuePtr;
- long i;
- Tcl_WideInt w;
+ ClientData ptr;
+ int type;
+ Tcl_Obj *valuePtr = *tosPtr;
- valuePtr = *tosPtr;
- tPtr = valuePtr->typePtr;
- converted = 0;
- if (IS_INTEGER_TYPE(tPtr)
- || ((tPtr == &tclDoubleType) && (valuePtr->bytes == NULL))) {
- /*
- * We already have a numeric internal rep, either some kind of
- * integer, or a "pure" double. (Need "pure" so that we know the
- * string rep of the double would not prefer to be interpreted as
- * an integer.)
- */
- } else {
- /*
- * Otherwise, we need to generate a numeric internal rep. from
- * the string rep.
- */
- s = Tcl_GetStringFromObj(valuePtr, &length);
- if (TclLooksLikeInt(s, length)) {
- GET_WIDE_OR_INT(result, valuePtr, i, w);
+ if (GetNumberFromObj(NULL, valuePtr, &ptr, &type) != TCL_OK) {
+ if (*pc == INST_UPLUS) {
+ /* ... +$NonNumeric => raise an error */
+ result = TCL_ERROR;
+ TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(valuePtr),
+ (valuePtr->typePtr? valuePtr->typePtr->name : "null")));
+ IllegalExprOperandType(interp, pc, valuePtr);
+ goto checkForCatch;
} else {
- result = Tcl_GetDoubleFromObj(NULL, valuePtr, &d);
+ /* ... TryConvertToNumeric($NonNumeric) is acceptable */
+ TRACE(("\"%.20s\" => not numeric\n", O2S(valuePtr)));
+ NEXT_INST_F(1, 0, 0);
}
- if (result == TCL_OK) {
- converted = 1;
+ }
+#ifndef ACCEPT_NAN
+ if (type == TCL_NUMBER_NAN) {
+ result = TCL_ERROR;
+ if (*pc == INST_UPLUS) {
+ /* ... +$NonNumeric => raise an error */
+ TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(valuePtr),
+ (valuePtr->typePtr? valuePtr->typePtr->name : "null")));
+ IllegalExprOperandType(interp, pc, valuePtr);
+ } else {
+ /* Numeric conversion of NaN -> error */
+ TRACE(("\"%.20s\" => IEEE FLOATING PT ERROR\n",
+ O2S(objResultPtr)));
+ TclExprFloatError(interp, *((CONST double *)ptr));
}
- result = TCL_OK; /* reset the result variable */
- tPtr = valuePtr->typePtr;
+ goto checkForCatch;
}
+#endif
/*
- * Ensure that the topmost stack object, if numeric, has a string rep
- * the same as the formatted version of its internal rep. This is
- * used, e.g., to make sure that "expr {0001}" yields "1", not
- * "0001". We implement this by _discarding_ the string rep since we
- * know it will be regenerated, if needed later, by formatting the
- * internal rep's value. Also check if there has been an IEEE floating
- * point error.
+ * Ensure that the numeric value has a string rep the same as
+ * the formatted version of its internal rep. This is used, e.g.,
+ * to make sure that "expr {0001}" yields "1", not "0001".
+ * We implement this by _discarding_ the string rep since we
+ * know it will be regenerated, if needed later, by formatting
+ * the internal rep's value.
*/
-
- objResultPtr = valuePtr;
- needNew = 0;
- if (IS_NUMERIC_TYPE(tPtr)) {
- if (Tcl_IsShared(valuePtr)) {
- if (valuePtr->bytes != NULL) {
- /*
- * We only need to make a copy of the object when it
- * already had a string rep
- */
- needNew = 1;
- if (tPtr == &tclIntType) {
- i = valuePtr->internalRep.longValue;
- TclNewLongObj(objResultPtr, i);
- } else if (tPtr == &tclWideIntType) {
- TclGetWide(w,valuePtr);
- TclNewWideIntObj(objResultPtr, w);
- } else {
- d = valuePtr->internalRep.doubleValue;
- TclNewDoubleObj(objResultPtr, d);
- }
- tPtr = objResultPtr->typePtr;
- }
- } else {
- Tcl_InvalidateStringRep(valuePtr);
- }
-
- if (tPtr == &tclDoubleType) {
- d = objResultPtr->internalRep.doubleValue;
- if (IS_NAN(d)) {
- TRACE(("\"%.20s\" => IEEE FLOATING PT ERROR\n",
- O2S(objResultPtr)));
- TclExprFloatError(interp, d);
- result = TCL_ERROR;
- goto checkForCatch;
- }
- }
- converted = converted; /* lint, converted not used. */
- TRACE(("\"%.20s\" => numeric, %s, %s\n", O2S(valuePtr),
- (converted? "converted" : "not converted"),
- (needNew? "new Tcl_Obj" : "same Tcl_Obj")));
- } else {
- TRACE(("\"%.20s\" => not numeric\n", O2S(valuePtr)));
+ if (valuePtr->bytes == NULL) {
+ TRACE(("\"%.20s\" => numeric, same Tcl_Obj\n", O2S(valuePtr)));
+ NEXT_INST_F(1, 0, 0);
}
- if (needNew) {
+ if (Tcl_IsShared(valuePtr)) {
+ /*
+ * Here we do some surgery within the Tcl_Obj internals.
+ * We want to copy the intrep, but not the string, so we
+ * temporarily hide the string so we do not copy it.
+ */
+ char *savedString = valuePtr->bytes;
+ valuePtr->bytes = NULL;
+ objResultPtr = Tcl_DuplicateObj(valuePtr);
+ valuePtr->bytes = savedString;
+ TRACE(("\"%.20s\" => numeric, new Tcl_Obj\n", O2S(valuePtr)));
NEXT_INST_F(1, 1, 1);
- } else {
- NEXT_INST_F(1, 0, 0);
}
+ TclInvalidateStringRep(valuePtr);
+ TRACE(("\"%.20s\" => numeric, same Tcl_Obj\n", O2S(valuePtr)));
+ NEXT_INST_F(1, 0, 0);
}
case INST_BREAK:
@@ -4779,7 +5514,7 @@ TclExecuteByteCode(interp, codePtr)
NEXT_INST_F(1, 0, -1);
case INST_PUSH_RETURN_CODE:
- TclNewLongObj(objResultPtr, result);
+ TclNewIntObj(objResultPtr, result);
TRACE(("=> %u\n", result));
NEXT_INST_F(1, 0, 1);
@@ -4788,6 +5523,7 @@ TclExecuteByteCode(interp, codePtr)
TRACE_WITH_OBJ(("=> "), objResultPtr);
NEXT_INST_F(1, 0, 1);
+/* TODO: normalize "valPtr" to "valuePtr" */
{
int opnd, opnd2, allocateDict;
Tcl_Obj *dictPtr, *valPtr;
@@ -4874,34 +5610,19 @@ TclExecuteByteCode(interp, codePtr)
break;
}
if (valPtr == NULL) {
- Tcl_DictObjPut(NULL, dictPtr, *tosPtr, Tcl_NewLongObj(opnd));
- } else if (valPtr->typePtr == &tclWideIntType) {
- Tcl_WideInt wvalue;
-
- Tcl_GetWideIntFromObj(NULL, valPtr, &wvalue);
- Tcl_DictObjPut(NULL, dictPtr, *tosPtr,
- Tcl_NewWideIntObj(wvalue + opnd));
- } else if (valPtr->typePtr == &tclIntType) {
- long value;
-
- Tcl_GetLongFromObj(NULL, valPtr, &value);
- Tcl_DictObjPut(NULL, dictPtr, *tosPtr,
- Tcl_NewLongObj(value + opnd));
+ Tcl_DictObjPut(NULL, dictPtr, *tosPtr, Tcl_NewIntObj(opnd));
} else {
- long value = 0; /* stop compiler warning */
- Tcl_WideInt wvalue;
-
- REQUIRE_WIDE_OR_INT(result, valPtr, value, wvalue);
- if (result != TCL_OK) {
- break;
+ Tcl_Obj *incrPtr = Tcl_NewIntObj(opnd);
+ Tcl_IncrRefCount(incrPtr);
+ if (Tcl_IsShared(valPtr)) {
+ valPtr = Tcl_DuplicateObj(valPtr);
+ Tcl_DictObjPut(NULL, dictPtr, *tosPtr, valPtr);
}
- if (valPtr->typePtr == &tclWideIntType) {
- Tcl_DictObjPut(NULL, dictPtr, *tosPtr,
- Tcl_NewWideIntObj(wvalue + opnd));
- } else {
- Tcl_DictObjPut(NULL, dictPtr, *tosPtr,
- Tcl_NewLongObj(value + opnd));
+ result = TclIncrObj(interp, valPtr, incrPtr);
+ if (result == TCL_OK) {
+ Tcl_InvalidateStringRep(dictPtr);
}
+ Tcl_DecrRefCount(incrPtr);
}
break;
case INST_DICT_UNSET:
@@ -5134,7 +5855,8 @@ TclExecuteByteCode(interp, codePtr)
}
TRACE_APPEND(("\"%.30s\" \"%.30s\" %d",
O2S(*(tosPtr-1)), O2S(*tosPtr), done));
- objResultPtr = Tcl_NewBooleanObj(done);
+ objResultPtr = eePtr->constants[done];
+ /*TODO: consider opt like INST_FOREACH_STEP4 */
NEXT_INST_F(5, 0, 1);
case INST_DICT_DONE:
@@ -5722,116 +6444,38 @@ IllegalExprOperandType(interp, pc, opndPtr)
Tcl_Obj *opndPtr; /* Points to the operand holding the value
* with the illegal type. */
{
- unsigned char opCode = *pc;
- CONST char *operator = operatorStrings[opCode - INST_LOR];
- if (opCode == INST_EXPON) {
+ ClientData ptr;
+ int type;
+ unsigned char opcode = *pc;
+ CONST char *description, *operator = operatorStrings[opcode - INST_LOR];
+ Tcl_Obj *msg = Tcl_NewObj();
+
+ if (opcode == INST_EXPON) {
operator = "**";
}
- Tcl_SetObjResult(interp, Tcl_NewObj());
- if ((opndPtr->bytes == NULL) || (opndPtr->length == 0)) {
- Tcl_AppendResult(interp, "can't use empty string as operand of \"",
- operator, "\"", (char *) NULL);
- } else {
- char *msg = "non-numeric string";
- char *s, *p;
- int length;
- int looksLikeInt = 0;
-
- s = Tcl_GetStringFromObj(opndPtr, &length);
- p = s;
- /*
- * strtod() isn't at all consistent about detecting Inf and NaN
- * between platforms.
- */
- if (length == 3) {
- if ((s[0]=='n' || s[0]=='N') && (s[1]=='a' || s[1]=='A') &&
- (s[2]=='n' || s[2]=='N')) {
- msg = "non-numeric floating-point value";
- goto makeErrorMessage;
- }
- if ((s[0]=='i' || s[0]=='I') && (s[1]=='n' || s[1]=='N') &&
- (s[2]=='f' || s[2]=='F')) {
- msg = "infinite floating-point value";
- goto makeErrorMessage;
- }
- }
-
- /*
- * We cannot use TclLooksLikeInt here because it passes strings like
- * "10;" [Bug 587140]. We'll accept as "looking like ints" for the
- * present purposes any string that looks formally like a
- * (decimal|octal|hex) integer.
- */
-
- while (length && isspace(UCHAR(*p))) {
- length--;
- p++;
- }
- if (length && ((*p == '+') || (*p == '-'))) {
- length--;
- p++;
- }
- if (length) {
- if ((*p == '0') && ((*(p+1) == 'x') || (*(p+1) == 'X'))) {
- p += 2;
- length -= 2;
- looksLikeInt = ((length > 0) && isxdigit(UCHAR(*p)));
- if (looksLikeInt) {
- length--;
- p++;
- while (length && isxdigit(UCHAR(*p))) {
- length--;
- p++;
- }
- }
- } else {
- looksLikeInt = (length && isdigit(UCHAR(*p)));
- if (looksLikeInt) {
- length--;
- p++;
- while (length && isdigit(UCHAR(*p))) {
- length--;
- p++;
- }
- }
- }
- while (length && isspace(UCHAR(*p))) {
- length--;
- p++;
- }
- looksLikeInt = !length;
- }
- if (looksLikeInt) {
- /*
- * If something that looks like an integer could not be converted,
- * then it *must* be a bad octal or too large to represent [Bug
- * 542588].
- */
-
- if (TclCheckBadOctal(NULL, s)) {
- msg = "invalid octal number";
- } else {
- msg = "integer value too large to represent";
- Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW",
- "integer value too large to represent", (char *) NULL);
- }
+ if (GetNumberFromObj(NULL, opndPtr, &ptr, &type) != TCL_OK) {
+ int numBytes;
+ CONST char *bytes = Tcl_GetStringFromObj(opndPtr, &numBytes);
+ if (numBytes == 0) {
+ description = "empty string";
+ } else if (TclCheckBadOctal(NULL, bytes)) {
+ description = "invalid octal number";
} else {
- /*
- * See if the operand can be interpreted as a double in order to
- * improve the error message.
- */
-
- double d;
-
- if (Tcl_GetDouble((Tcl_Interp *) NULL, s, &d) == TCL_OK) {
- msg = "floating-point value";
- }
+ description = "non-numeric string";
}
- makeErrorMessage:
- Tcl_AppendResult(interp, "can't use ", msg, " as operand of \"",
- operator, "\"", (char *) NULL);
+ } else if (type == TCL_NUMBER_NAN) {
+ description = "non-numeric floating-point value";
+ } else if (type == TCL_NUMBER_DOUBLE) {
+ description = "floating-point value";
+ } else {
+ /* TODO: No caller needs this. Eliminate? */
+ description = "(big) integer";
}
+
+ TclObjPrintf(NULL, msg, "can't use %s as operand of \"%s\"",
+ description, operator);
+ Tcl_SetObjResult(interp, msg);
}
/*
@@ -6054,6 +6698,7 @@ GetOpcodeName(pc)
}
#endif /* TCL_COMPILE_DEBUG */
+
/*
*----------------------------------------------------------------------
*
@@ -6079,11 +6724,11 @@ TclExprFloatError(interp, value)
{
CONST char *s;
- if ((errno == EDOM) || IS_NAN(value)) {
+ if ((errno == EDOM) || TclIsNaN(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)) {
+ } else if ((errno == ERANGE) || TclIsInfinite(value)) {
if (value == 0.0) {
s = "floating-point value too small to represent";
Tcl_SetObjResult(interp, Tcl_NewStringObj(s, -1));
@@ -6571,6 +7216,7 @@ StringForResultCode(result)
return buf;
}
#endif /* TCL_COMPILE_DEBUG */
+#if 0
/*
*----------------------------------------------------------------------
@@ -6706,3 +7352,4 @@ ExponLong(i, i2, errExpon)
}
return result * i;
}
+#endif
diff --git a/generic/tclInt.decls b/generic/tclInt.decls
index 6ca9761..9a07c73 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.92 2005/08/05 23:56:28 dkf Exp $
+# RCS: @(#) $Id: tclInt.decls,v 1.93 2005/10/08 14:42:45 dgp Exp $
library tcl
@@ -210,10 +210,10 @@ declare 46 generic {
# Tcl_Obj *TclIncrIndexedScalar(Tcl_Interp *interp, int localIndex,
# long incrAmount)
#}
-declare 49 generic {
- Tcl_Obj *TclIncrVar2(Tcl_Interp *interp, Tcl_Obj *part1Ptr,
- Tcl_Obj *part2Ptr, long incrAmount, int part1NotParsed)
-}
+#declare 49 generic {
+# Tcl_Obj *TclIncrVar2(Tcl_Interp *interp, Tcl_Obj *part1Ptr,
+# Tcl_Obj *part2Ptr, long incrAmount, int part1NotParsed)
+#}
declare 50 generic {
void TclInitCompiledLocals(Tcl_Interp *interp, CallFrame *framePtr,
Namespace *nsPtr)
@@ -553,9 +553,9 @@ declare 138 generic {
# char *sym2, Tcl_PackageInitProc **proc1Ptr,
# Tcl_PackageInitProc **proc2Ptr, ClientData *clientDataPtr)
#}
-declare 140 generic {
- int TclLooksLikeInt(CONST char *bytes, int length)
-}
+#declare 140 generic {
+# int TclLooksLikeInt(CONST char *bytes, int length)
+#}
# This is used by TclX, but should otherwise be considered private
declare 141 generic {
CONST84_RETURN char *TclpGetCwd(Tcl_Interp *interp, Tcl_DString *cwdPtr)
@@ -709,10 +709,10 @@ declare 173 generic {
# added for 8.4.3
-declare 174 generic {
- Tcl_Obj *TclIncrWideVar2(Tcl_Interp *interp, Tcl_Obj *part1Ptr,
- Tcl_Obj *part2Ptr, Tcl_WideInt wideIncrAmount, int part1NotParsed)
-}
+#declare 174 generic {
+# Tcl_Obj *TclIncrWideVar2(Tcl_Interp *interp, Tcl_Obj *part1Ptr,
+# Tcl_Obj *part2Ptr, Tcl_WideInt wideIncrAmount, int part1NotParsed)
+#}
# Factoring out of trace code
diff --git a/generic/tclInt.h b/generic/tclInt.h
index b810845..6dd07b0 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -12,13 +12,20 @@
* 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.252 2005/09/14 03:46:50 dgp Exp $
+ * RCS: @(#) $Id: tclInt.h,v 1.253 2005/10/08 14:42:45 dgp Exp $
*/
#ifndef _TCLINT
#define _TCLINT
/*
+ * Some numerics configuration options
+ */
+
+#undef NO_WIDE_TYPE
+#undef ACCEPT_NAN
+
+/*
* Common include files needed by most of the Tcl source files are included
* here, so that system-dependent personalizations for the include files only
* have to be made in once place. This results in a few extra includes, but
@@ -98,6 +105,14 @@ typedef int ptrdiff_t;
#endif
/*
+ * When Tcl_WideInt and long are the same type, there's no value in
+ * having a tclWideIntType separate from the tclIntType.
+ */
+#ifdef TCL_WIDE_INT_IS_LONG
+#define NO_WIDE_TYPE
+#endif
+
+/*
* The following procedures allow namespaces to be customized to support
* special name resolution rules for commands/variables.
*/
@@ -1873,6 +1888,35 @@ typedef struct ProcessGlobalValue {
} ProcessGlobalValue;
/*
+ *----------------------------------------------------------------------
+ * Flags for TclParseNumber
+ *----------------------------------------------------------------------
+ */
+
+#define TCL_PARSE_DECIMAL_ONLY 1
+ /* Leading zero doesn't denote octal or hex */
+#define TCL_PARSE_OCTAL_ONLY 2
+ /* Parse octal even without prefix */
+#define TCL_PARSE_HEXADECIMAL_ONLY 4
+ /* Parse hexadecimal even without prefix */
+#define TCL_PARSE_INTEGER_ONLY 8
+ /* Disable floating point parsing */
+#define TCL_PARSE_SCAN_PREFIXES 16
+ /* 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.
*----------------------------------------------------------------
@@ -1897,6 +1941,7 @@ MODULE_SCOPE ClientData tclTimeClientData;
* Variables denoting the Tcl object types defined in the core.
*/
+MODULE_SCOPE Tcl_ObjType tclBignumType;
MODULE_SCOPE Tcl_ObjType tclBooleanType;
MODULE_SCOPE Tcl_ObjType tclByteArrayType;
MODULE_SCOPE Tcl_ObjType tclByteCodeType;
@@ -1909,7 +1954,9 @@ MODULE_SCOPE Tcl_ObjType tclProcBodyType;
MODULE_SCOPE Tcl_ObjType tclStringType;
MODULE_SCOPE Tcl_ObjType tclArraySearchType;
MODULE_SCOPE Tcl_ObjType tclNsNameType;
+#ifndef NO_WIDE_TYPE
MODULE_SCOPE Tcl_ObjType tclWideIntType;
+#endif
MODULE_SCOPE Tcl_ObjType tclRegexpType;
/*
@@ -1961,6 +2008,7 @@ MODULE_SCOPE void TclAppendObjToErrorInfo(Tcl_Interp *interp,
MODULE_SCOPE int TclArraySet(Tcl_Interp *interp,
Tcl_Obj *arrayNameObj, Tcl_Obj *arrayElemObj);
MODULE_SCOPE double TclBignumToDouble(mp_int* bignum);
+MODULE_SCOPE double TclCeil(mp_int* a);
MODULE_SCOPE int TclCheckBadOctal(Tcl_Interp *interp,CONST char *value);
MODULE_SCOPE int TclChanCreateObjCmd(ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]);
@@ -2000,6 +2048,7 @@ MODULE_SCOPE void TclFinalizeObjects(void);
MODULE_SCOPE void TclFinalizePreserve(void);
MODULE_SCOPE void TclFinalizeSynchronization(void);
MODULE_SCOPE void TclFinalizeThreadData(void);
+MODULE_SCOPE double TclFloor(mp_int* a);
MODULE_SCOPE void TclFormatNaN(double value, char* buffer);
MODULE_SCOPE int TclFormatObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
CONST char *format, ...);
@@ -2012,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);
@@ -2019,7 +2071,13 @@ MODULE_SCOPE Tcl_Obj * TclGetProcessGlobalValue(ProcessGlobalValue *pgvPtr);
MODULE_SCOPE int TclGlob(Tcl_Interp *interp, char *pattern,
Tcl_Obj *unquotedPrefix, int globFlags,
Tcl_GlobTypeData* types);
+MODULE_SCOPE int TclIncrObj(Tcl_Interp *interp, Tcl_Obj *valuePtr,
+ Tcl_Obj *incrPtr);
+MODULE_SCOPE Tcl_Obj * TclIncrObjVar2(Tcl_Interp *interp, Tcl_Obj *part1Ptr,
+ Tcl_Obj *part2Ptr, Tcl_Obj *incrPtr, int flags);
MODULE_SCOPE void TclInitAlloc(void);
+MODULE_SCOPE int TclInitBignumFromDouble(Tcl_Interp *interp, double d,
+ mp_int *b);
MODULE_SCOPE void TclInitDbCkalloc(void);
MODULE_SCOPE void TclInitDoubleConversion(void);
MODULE_SCOPE void TclInitEmbeddedConfigurationInformation(
@@ -2062,9 +2120,14 @@ MODULE_SCOPE int TclParseBackslash(CONST char *src,
int numBytes, int *readPtr, char *dst);
MODULE_SCOPE int TclParseHex(CONST char *src, int numBytes,
Tcl_UniChar *resultPtr);
+MODULE_SCOPE int TclParseNumber(Tcl_Interp* interp, Tcl_Obj* objPtr,
+ CONST char* type, CONST char* string,
+ size_t length, CONST char** endPtrPtr, int flags);
MODULE_SCOPE void TclParseInit(Tcl_Interp *interp, CONST char *string,
int numBytes, Tcl_Parse *parsePtr);
+#if 0
MODULE_SCOPE int TclParseInteger(CONST char *string, int numBytes);
+#endif
MODULE_SCOPE int TclParseWhiteSpace(CONST char *src,
int numBytes, Tcl_Parse *parsePtr, char *typePtr);
MODULE_SCOPE int TclProcessReturn(Tcl_Interp *interp,
@@ -2134,10 +2197,11 @@ MODULE_SCOPE void TclRememberMutex(Tcl_Mutex *mutex);
MODULE_SCOPE void TclRemoveScriptLimitCallbacks(Tcl_Interp *interp);
MODULE_SCOPE void TclSetBgErrorHandler(Tcl_Interp *interp,
Tcl_Obj *cmdPrefix);
+MODULE_SCOPE void TclSetBignumIntRep (Tcl_Obj *objPtr,
+ mp_int *bignumValue);
MODULE_SCOPE void TclSetProcessGlobalValue(ProcessGlobalValue *pgvPtr,
Tcl_Obj *newValue, Tcl_Encoding encoding);
MODULE_SCOPE VOID TclSignalExitThread(Tcl_ThreadId id, int result);
-MODULE_SCOPE double TclStrToD(CONST char* string, CONST char** endPtr);
MODULE_SCOPE int TclSubstTokens(Tcl_Interp *interp, Tcl_Token *tokenPtr,
int count, int *tokensLeftPtr);
MODULE_SCOPE void TclTransferResult(Tcl_Interp *sourceInterp, int result,
@@ -2516,6 +2580,11 @@ MODULE_SCOPE Tcl_Obj * TclPtrSetVar(Tcl_Interp *interp,
Var *varPtr, Var *arrayPtr, CONST char *part1,
CONST char *part2, Tcl_Obj *newValuePtr,
CONST int flags);
+MODULE_SCOPE Tcl_Obj * TclPtrIncrObjVar (Tcl_Interp *interp,
+ Var *varPtr, Var *arrayPtr, CONST char *part1,
+ CONST char *part2, Tcl_Obj *incrPtr,
+ CONST int flags);
+#if 0
MODULE_SCOPE Tcl_Obj * TclPtrIncrVar(Tcl_Interp *interp,
Var *varPtr, Var *arrayPtr, CONST char *part1,
CONST char *part2, CONST long i, CONST int flags);
@@ -2523,6 +2592,7 @@ MODULE_SCOPE Tcl_Obj * TclPtrIncrWideVar(Tcl_Interp *interp,
Var *varPtr, Var *arrayPtr, CONST char *part1,
CONST char *part2, CONST Tcl_WideInt i,
CONST int flags);
+#endif
MODULE_SCOPE void TclInvalidateNsPath(Namespace *nsPtr);
/*
@@ -2737,25 +2807,21 @@ MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr);
}\
+#if 0
/*
*----------------------------------------------------------------
* Macro used by the Tcl core to get a Tcl_WideInt value out of a Tcl_Obj of
- * the "wideInt" type. Different implementation on different platforms
- * depending whether TCL_WIDE_INT_IS_LONG.
+ * the "wideInt" type.
*----------------------------------------------------------------
*/
-#ifdef TCL_WIDE_INT_IS_LONG
-# define TclGetWide(resultVar, objPtr) \
- (resultVar) = (objPtr)->internalRep.longValue
-# define TclGetLongFromWide(resultVar, objPtr) \
- (resultVar) = (objPtr)->internalRep.longValue
-#else
+#ifndef NO_WIDE_TYPE
# define TclGetWide(resultVar, objPtr) \
(resultVar) = (objPtr)->internalRep.wideValue
# define TclGetLongFromWide(resultVar, objPtr) \
(resultVar) = Tcl_WideAsLong((objPtr)->internalRep.wideValue)
#endif
+#endif
/*
*----------------------------------------------------------------
@@ -2818,7 +2884,10 @@ MODULE_SCOPE void * TclBNAlloc(size_t nBytes);
MODULE_SCOPE void * TclBNRealloc(void *oldBlock, size_t newNBytes);
MODULE_SCOPE void TclBNFree(void *block);
MODULE_SCOPE void TclBNInitBignumFromLong(mp_int *bignum, long initVal);
-
+MODULE_SCOPE void TclBNInitBignumFromWideInt(mp_int* bignum,
+ Tcl_WideInt initVal);
+MODULE_SCOPE void TclBNInitBignumFromWideUInt(mp_int* bignum,
+ Tcl_WideUInt initVal);
/*
*----------------------------------------------------------------
@@ -2876,11 +2945,13 @@ MODULE_SCOPE void TclBNInitBignumFromLong(mp_int *bignum, long initVal);
#define TclSetBooleanObj(objPtr, b) \
TclSetIntObj((objPtr), ((b)? 1 : 0));
+#ifndef NO_WIDE_TYPE
#define TclSetWideIntObj(objPtr, w) \
TclInvalidateStringRep(objPtr);\
TclFreeIntRep(objPtr); \
(objPtr)->internalRep.wideValue = (Tcl_WideInt)(w); \
(objPtr)->typePtr = &tclWideIntType
+#endif
#define TclSetDoubleObj(objPtr, d) \
TclInvalidateStringRep(objPtr);\
@@ -2923,14 +2994,6 @@ MODULE_SCOPE void TclBNInitBignumFromLong(mp_int *bignum, long initVal);
#define TclNewBooleanObj(objPtr, b) \
TclNewIntObj((objPtr), ((b)? 1 : 0))
-#define TclNewWideIntObj(objPtr, w) \
- TclIncrObjsAllocated(); \
- TclAllocObjStorage(objPtr); \
- (objPtr)->refCount = 0; \
- (objPtr)->bytes = NULL; \
- (objPtr)->internalRep.wideValue = (Tcl_WideInt)(w); \
- (objPtr)->typePtr = &tclWideIntType
-
#define TclNewDoubleObj(objPtr, d) \
TclIncrObjsAllocated(); \
TclAllocObjStorage(objPtr); \
@@ -2953,9 +3016,6 @@ MODULE_SCOPE void TclBNInitBignumFromLong(mp_int *bignum, long initVal);
#define TclNewBooleanObj(objPtr, b) \
(objPtr) = Tcl_NewBooleanObj(b)
-#define TclNewWideIntObj(objPtr, w)\
- (objPtr) = Tcl_NewWideIntObj(w)
-
#define TclNewDoubleObj(objPtr, d) \
(objPtr) = Tcl_NewDoubleObj(d)
@@ -2963,6 +3023,23 @@ MODULE_SCOPE void TclBNInitBignumFromLong(mp_int *bignum, long initVal);
(objPtr) = Tcl_NewStringObj((s), (len))
#endif /* TCL_MEM_DEBUG */
+/*
+ *----------------------------------------------------------------
+ * Macros used by the Tcl core to test for some special double values.
+ * The ANSI C "prototypes" for these macros are:
+ *
+ * MODULE_SCOPE int TclIsInfinite _ANSI_ARGS_((double d));
+ * MODULE_SCOPE int TclIsNaN _ANSI_ARGS_((double d));
+ */
+
+#ifdef _MSC_VER
+#define TclIsInfinite(d) ( ! (_finite((d))) )
+#define TclIsNaN(d) (_isnan((d)))
+#else
+#define TclIsInfinite(d) ( (d) > DBL_MAX || (d) < -DBL_MAX )
+#define TclIsNaN(d) ((d) != (d))
+#endif
+
#include "tclPort.h"
#include "tclIntDecls.h"
#include "tclIntPlatDecls.h"
diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h
index 4d1fff3..4b19ca6 100644
--- a/generic/tclIntDecls.h
+++ b/generic/tclIntDecls.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: tclIntDecls.h,v 1.83 2005/08/05 23:57:35 dkf Exp $
+ * RCS: @(#) $Id: tclIntDecls.h,v 1.84 2005/10/08 14:42:45 dgp Exp $
*/
#ifndef _TCLINTDECLS
@@ -271,13 +271,7 @@ EXTERN int TclInExit _ANSI_ARGS_((void));
#endif
/* Slot 47 is reserved */
/* Slot 48 is reserved */
-#ifndef TclIncrVar2_TCL_DECLARED
-#define TclIncrVar2_TCL_DECLARED
-/* 49 */
-EXTERN Tcl_Obj * TclIncrVar2 _ANSI_ARGS_((Tcl_Interp * interp,
- Tcl_Obj * part1Ptr, Tcl_Obj * part2Ptr,
- long incrAmount, int part1NotParsed));
-#endif
+/* Slot 49 is reserved */
#ifndef TclInitCompiledLocals_TCL_DECLARED
#define TclInitCompiledLocals_TCL_DECLARED
/* 50 */
@@ -684,12 +678,7 @@ EXTERN CONST84_RETURN char * TclGetEnv _ANSI_ARGS_((CONST char * name,
Tcl_DString * valuePtr));
#endif
/* Slot 139 is reserved */
-#ifndef TclLooksLikeInt_TCL_DECLARED
-#define TclLooksLikeInt_TCL_DECLARED
-/* 140 */
-EXTERN int TclLooksLikeInt _ANSI_ARGS_((CONST char * bytes,
- int length));
-#endif
+/* Slot 140 is reserved */
#ifndef TclpGetCwd_TCL_DECLARED
#define TclpGetCwd_TCL_DECLARED
/* 141 */
@@ -872,14 +861,7 @@ EXTERN int TclUniCharMatch _ANSI_ARGS_((
CONST Tcl_UniChar * pattern, int ptnLen,
int nocase));
#endif
-#ifndef TclIncrWideVar2_TCL_DECLARED
-#define TclIncrWideVar2_TCL_DECLARED
-/* 174 */
-EXTERN Tcl_Obj * TclIncrWideVar2 _ANSI_ARGS_((Tcl_Interp * interp,
- Tcl_Obj * part1Ptr, Tcl_Obj * part2Ptr,
- Tcl_WideInt wideIncrAmount,
- int part1NotParsed));
-#endif
+/* Slot 174 is reserved */
#ifndef TclCallVarTraces_TCL_DECLARED
#define TclCallVarTraces_TCL_DECLARED
/* 175 */
@@ -1167,7 +1149,7 @@ typedef struct TclIntStubs {
int (*tclInExit) _ANSI_ARGS_((void)); /* 46 */
void *reserved47;
void *reserved48;
- Tcl_Obj * (*tclIncrVar2) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * part1Ptr, Tcl_Obj * part2Ptr, long incrAmount, int part1NotParsed)); /* 49 */
+ void *reserved49;
void (*tclInitCompiledLocals) _ANSI_ARGS_((Tcl_Interp * interp, CallFrame * framePtr, Namespace * nsPtr)); /* 50 */
int (*tclInterpInit) _ANSI_ARGS_((Tcl_Interp * interp)); /* 51 */
void *reserved52;
@@ -1263,7 +1245,7 @@ typedef struct TclIntStubs {
void *reserved137;
CONST84_RETURN char * (*tclGetEnv) _ANSI_ARGS_((CONST char * name, Tcl_DString * valuePtr)); /* 138 */
void *reserved139;
- int (*tclLooksLikeInt) _ANSI_ARGS_((CONST char * bytes, int length)); /* 140 */
+ void *reserved140;
CONST84_RETURN char * (*tclpGetCwd) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_DString * cwdPtr)); /* 141 */
int (*tclSetByteCodeFromAny) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, CompileHookProc * hookProc, ClientData clientData)); /* 142 */
int (*tclAddLiteralObj) _ANSI_ARGS_((struct CompileEnv * envPtr, Tcl_Obj * objPtr, LiteralEntry ** litPtrPtr)); /* 143 */
@@ -1297,7 +1279,7 @@ typedef struct TclIntStubs {
int (*tclCheckExecutionTraces) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * command, int numChars, Command * cmdPtr, int result, int traceFlags, int objc, Tcl_Obj *CONST objv[])); /* 171 */
int (*tclInThreadExit) _ANSI_ARGS_((void)); /* 172 */
int (*tclUniCharMatch) _ANSI_ARGS_((CONST Tcl_UniChar * string, int strLen, CONST Tcl_UniChar * pattern, int ptnLen, int nocase)); /* 173 */
- Tcl_Obj * (*tclIncrWideVar2) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * part1Ptr, Tcl_Obj * part2Ptr, Tcl_WideInt wideIncrAmount, int part1NotParsed)); /* 174 */
+ void *reserved174;
int (*tclCallVarTraces) _ANSI_ARGS_((Interp * iPtr, Var * arrayPtr, Var * varPtr, CONST char * part1, CONST char * part2, int flags, int leaveErrMsg)); /* 175 */
void (*tclCleanupVar) _ANSI_ARGS_((Var * varPtr, Var * arrayPtr)); /* 176 */
void (*tclVarErrMsg) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * part1, CONST char * part2, CONST char * operation, CONST char * reason)); /* 177 */
@@ -1520,10 +1502,7 @@ extern TclIntStubs *tclIntStubsPtr;
#endif
/* Slot 47 is reserved */
/* Slot 48 is reserved */
-#ifndef TclIncrVar2
-#define TclIncrVar2 \
- (tclIntStubsPtr->tclIncrVar2) /* 49 */
-#endif
+/* Slot 49 is reserved */
#ifndef TclInitCompiledLocals
#define TclInitCompiledLocals \
(tclIntStubsPtr->tclInitCompiledLocals) /* 50 */
@@ -1802,10 +1781,7 @@ extern TclIntStubs *tclIntStubsPtr;
(tclIntStubsPtr->tclGetEnv) /* 138 */
#endif
/* Slot 139 is reserved */
-#ifndef TclLooksLikeInt
-#define TclLooksLikeInt \
- (tclIntStubsPtr->tclLooksLikeInt) /* 140 */
-#endif
+/* Slot 140 is reserved */
#ifndef TclpGetCwd
#define TclpGetCwd \
(tclIntStubsPtr->tclpGetCwd) /* 141 */
@@ -1929,10 +1905,7 @@ extern TclIntStubs *tclIntStubsPtr;
#define TclUniCharMatch \
(tclIntStubsPtr->tclUniCharMatch) /* 173 */
#endif
-#ifndef TclIncrWideVar2
-#define TclIncrWideVar2 \
- (tclIntStubsPtr->tclIncrWideVar2) /* 174 */
-#endif
+/* Slot 174 is reserved */
#ifndef TclCallVarTraces
#define TclCallVarTraces \
(tclIntStubsPtr->tclCallVarTraces) /* 175 */
diff --git a/generic/tclLink.c b/generic/tclLink.c
index b16a113..2ab72ff 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.12 2005/09/08 10:49:19 dkf Exp $
+ * RCS: @(#) $Id: tclLink.c,v 1.13 2005/10/08 14:42:45 dgp Exp $
*/
#include "tclInt.h"
@@ -383,9 +383,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/tclObj.c b/generic/tclObj.c
index 89ff127..b76055f 100644
--- a/generic/tclObj.c
+++ b/generic/tclObj.c
@@ -12,22 +12,14 @@
* 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.95 2005/09/05 10:25:54 dkf Exp $
+ * RCS: @(#) $Id: tclObj.c,v 1.96 2005/10/08 14:42:45 dgp Exp $
*/
#include "tclInt.h"
#include "tommath.h"
#include <float.h>
-/*
- * Define test for NaN
- */
-
-#ifdef _MSC_VER
-#define IS_NAN(f) _isnan((f))
-#else
-#define IS_NAN(f) ((f) != (f))
-#endif
+#define BIGNUM_AUTO_NARROW 1
/*
* Table of all object types.
@@ -153,41 +145,46 @@ static Tcl_ThreadDataKey pendingObjDataKey;
*/
#define PACK_BIGNUM(bignum, objPtr) \
- do { \
- (objPtr)->internalRep.bignumValue.digits = (void*) (bignum).dp; \
- (objPtr)->internalRep.bignumValue.misc = ( \
- ((bignum).sign << 30) \
- | ((bignum).alloc << 15) \
- | ((bignum).used)); \
- } while (0)
+ if ((bignum).used > 0x7fff) { \
+ mp_int *temp = (void *) ckalloc((unsigned) sizeof(mp_int)); \
+ *temp = bignum; \
+ (objPtr)->internalRep.ptrAndLongRep.ptr = (void*) temp; \
+ (objPtr)->internalRep.ptrAndLongRep.value = -1; \
+ } else { \
+ if ((bignum).alloc > 0x7fff) { \
+ mp_shrink(&(bignum)); \
+ } \
+ (objPtr)->internalRep.ptrAndLongRep.ptr = (void*) (bignum).dp; \
+ (objPtr)->internalRep.ptrAndLongRep.value = ( ((bignum).sign << 30) \
+ | ((bignum).alloc << 15) | ((bignum).used)); \
+ }
#define UNPACK_BIGNUM(objPtr, bignum) \
- do { \
- (bignum).dp = (mp_digit*) (objPtr)->internalRep.bignumValue.digits; \
- (bignum).sign = (objPtr)->internalRep.bignumValue.misc >> 30; \
+ if ((objPtr)->internalRep.ptrAndLongRep.value == -1) { \
+ (bignum) = *((mp_int *) ((objPtr)->internalRep.ptrAndLongRep.ptr)); \
+ } else { \
+ (bignum).dp = (mp_digit*) (objPtr)->internalRep.ptrAndLongRep.ptr; \
+ (bignum).sign = (objPtr)->internalRep.ptrAndLongRep.value >> 30; \
(bignum).alloc = \
- ((objPtr)->internalRep.bignumValue.misc >> 15) & 0x7fff; \
- (bignum).used = (objPtr)->internalRep.bignumValue.misc & 0x7fff; \
- } while (0)
+ ((objPtr)->internalRep.ptrAndLongRep.value >> 15) & 0x7fff; \
+ (bignum).used = (objPtr)->internalRep.ptrAndLongRep.value & 0x7fff; \
+ }
/*
* Prototypes for procedures defined later in this file:
*/
+static int ParseBoolean _ANSI_ARGS_((Tcl_Obj *objPtr));
static int SetBooleanFromAny _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Obj *objPtr));
static int SetDoubleFromAny _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Obj *objPtr));
static int SetIntFromAny _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Obj *objPtr));
-static int SetIntOrWideFromAny _ANSI_ARGS_((Tcl_Interp* interp,
- Tcl_Obj *objPtr));
static void UpdateStringOfDouble _ANSI_ARGS_((Tcl_Obj *objPtr));
static void UpdateStringOfInt _ANSI_ARGS_((Tcl_Obj *objPtr));
-static int SetWideIntFromAny _ANSI_ARGS_((Tcl_Interp *interp,
- Tcl_Obj *objPtr));
-#ifndef TCL_WIDE_INT_IS_LONG
+#ifndef NO_WIDE_TYPE
static void UpdateStringOfWideInt _ANSI_ARGS_((Tcl_Obj *objPtr));
#endif
@@ -195,8 +192,8 @@ static void FreeBignum _ANSI_ARGS_((Tcl_Obj *objPtr));
static void DupBignum _ANSI_ARGS_((Tcl_Obj *objPtr,
Tcl_Obj *copyPtr));
static void UpdateStringOfBignum _ANSI_ARGS_((Tcl_Obj *objPtr));
-static int SetBignumFromAny _ANSI_ARGS_((Tcl_Interp* interp,
- Tcl_Obj* objPtr));
+static int GetBignumFromObj _ANSI_ARGS_((Tcl_Interp *interp,
+ Tcl_Obj *objPtr, int copy, mp_int *bignumValue));
/*
* Prototypes for the array hash key methods.
@@ -253,24 +250,24 @@ Tcl_ObjType tclIntType = {
SetIntFromAny /* setFromAnyProc */
};
+#ifndef NO_WIDE_TYPE
Tcl_ObjType tclWideIntType = {
"wideInt", /* name */
(Tcl_FreeInternalRepProc *) NULL, /* freeIntRepProc */
(Tcl_DupInternalRepProc *) NULL, /* dupIntRepProc */
-#ifdef TCL_WIDE_INT_IS_LONG
- UpdateStringOfInt, /* updateStringProc */
-#else /* !TCL_WIDE_INT_IS_LONG */
UpdateStringOfWideInt, /* updateStringProc */
-#endif /* TCL_WIDE_INT_IS_LONG */
- SetWideIntFromAny /* setFromAnyProc */
+ NULL /* setFromAnyProc */
};
+#endif
+
+
Tcl_ObjType tclBignumType = {
"bignum", /* name */
FreeBignum, /* freeIntRepProc */
DupBignum, /* dupIntRepProc */
UpdateStringOfBignum, /* updateStringProc */
- SetBignumFromAny /* setFromAnyProc */
+ NULL /* setFromAnyProc */
};
/*
@@ -375,8 +372,6 @@ TclInitObjSubsystem()
Tcl_RegisterObjType(&tclDoubleType);
Tcl_RegisterObjType(&tclEndOffsetType);
Tcl_RegisterObjType(&tclIntType);
- Tcl_RegisterObjType(&tclWideIntType);
- Tcl_RegisterObjType(&tclBignumType);
Tcl_RegisterObjType(&tclStringType);
Tcl_RegisterObjType(&tclDictType);
Tcl_RegisterObjType(&tclByteCodeType);
@@ -871,7 +866,7 @@ TclFreeObj(objPtr)
typePtr->freeIntRepProc(objPtr);
ObjDeletionUnlock(context);
}
- Tcl_InvalidateStringRep(objPtr);
+ TclInvalidateStringRep(objPtr);
Tcl_MutexLock(&tclObjMutex);
ckfree((char *) objPtr);
@@ -1285,92 +1280,47 @@ Tcl_GetBooleanFromObj(interp, objPtr, boolPtr)
register Tcl_Obj *objPtr; /* The object from which to get boolean. */
register int *boolPtr; /* Place to store resulting boolean. */
{
- double d;
- long l;
-
- /*
- * The flow through this routine is "optimized" to avoid the generation of
- * string rep. for "pure" numeric values. However, once the string rep is
- * generated it's fairly inefficient at determining a string is *not* a
- * valid boolean. It has to scan the string as many as four times (ruling
- * out "double", "long", "wideint", and "boolean" in turn) to figure out
- * that an invalid boolean value is stored in objPtr->bytes.
- */
-
- if (objPtr->typePtr == &tclIntType) {
- *boolPtr = (int) (objPtr->internalRep.longValue != 0);
- return TCL_OK;
- }
- if (objPtr->typePtr == &tclBooleanType) {
- *boolPtr = (int) objPtr->internalRep.longValue;
- return TCL_OK;
- }
- if (objPtr->typePtr == &tclWideIntType) {
- *boolPtr = (int) (objPtr->internalRep.wideValue != 0);
- return TCL_OK;
- }
-
- /*
- * Caution: Don't be tempted to check directly for the "double"
- * Tcl_ObjType and then compare the intrep to 0.0. This isn't reliable
- * because a "double" Tcl_ObjType can hold the NaN value. Use the API
- * Tcl_GetDoubleFromObj, which does the checking for us.
- */
-
- /*
- * The following call retrieves a numeric value without generating the
- * string rep of a double.
- */
-
- if (Tcl_GetDoubleFromObj(NULL, objPtr, &d) == TCL_OK) {
- *boolPtr = (d != 0.0);
-
- /*
- * Tcl_GetDoubleFromObj() will succeed on the strings "0" and "1", but
- * we'd rather keep those values around as a better objType for
- * boolean value. Following call will shimmer appropriately.
- */
-
- if (objPtr->bytes != NULL) {
- SetBooleanFromAny(NULL, objPtr);
+ do {
+ if (objPtr->typePtr == &tclIntType) {
+ *boolPtr = (objPtr->internalRep.longValue != 0);
+ return TCL_OK;
}
- return TCL_OK;
- }
-
- /*
- * Value didn't already have a numeric intrep, but perhaps we can generate
- * one. Try a long value first...
- */
-
- if (Tcl_GetLongFromObj(NULL, objPtr, &l) == TCL_OK) {
- *boolPtr = (l != 0);
- return TCL_OK;
- }
-#ifndef TCL_WIDE_INT_IS_LONG
- else {
- Tcl_WideInt w;
-
- /*
- * ...then a wide. Check in that order so that we don't promote
- * anything to wide unnecessarily.
- */
-
- if (Tcl_GetWideIntFromObj(NULL, objPtr, &w) == TCL_OK) {
- *boolPtr = (w != 0);
+ if (objPtr->typePtr == &tclBooleanType) {
+ *boolPtr = (int) objPtr->internalRep.longValue;
return TCL_OK;
}
- }
+ if (objPtr->typePtr == &tclDoubleType) {
+ /*
+ * Caution: Don't be tempted to check directly for the "double"
+ * Tcl_ObjType and then compare the intrep to 0.0. This isn't
+ * reliable because a "double" Tcl_ObjType can hold the NaN value.
+ * Use the API Tcl_GetDoubleFromObj, which does the checking and
+ * sets the proper error message for us.
+ */
+ double d;
+ if (Tcl_GetDoubleFromObj(interp, objPtr, &d) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ *boolPtr = (d != 0.0);
+ return TCL_OK;
+ }
+ if (objPtr->typePtr == &tclBignumType) {
+#ifdef BIGNUM_AUTO_NARROW
+ *boolPtr = 1;
+#else
+ *boolPtr = ((objPtr->internalRep.ptrAndLongRep.value & 0x7fff)!=0);
#endif
-
- /*
- * Finally, check for the string values like "yes" and generate error
- * message for non-boolean values.
- */
-
- if (SetBooleanFromAny(interp, objPtr) == TCL_OK) {
- *boolPtr = (int) objPtr->internalRep.longValue;
- return TCL_OK;
- }
+ return TCL_OK;
+ }
+#ifndef NO_WIDE_TYPE
+ if (objPtr->typePtr == &tclWideIntType) {
+ *boolPtr = (objPtr->internalRep.wideValue != 0);
+ return TCL_OK;
+ }
+#endif
+ } while ((ParseBoolean(objPtr) == TCL_OK) || (TCL_OK ==
+ TclParseNumber(interp, objPtr, "boolean value",
+ NULL, -1, NULL, 0)));
return TCL_ERROR;
}
@@ -1399,9 +1349,6 @@ SetBooleanFromAny(interp, objPtr)
Tcl_Interp *interp; /* Used for error reporting if not NULL. */
register Tcl_Obj *objPtr; /* The object to convert. */
{
- char *str, lowerCase[6];
- int i, newBool, length;
-
/*
* For some "pure" numeric Tcl_ObjTypes (no string rep), we can determine
* whether a boolean conversion is possible without generating the string
@@ -1409,9 +1356,6 @@ SetBooleanFromAny(interp, objPtr)
*/
if (objPtr->bytes == NULL) {
- if (objPtr->typePtr == &tclDoubleType) {
- goto badBoolean;
- }
if (objPtr->typePtr == &tclIntType) {
switch (objPtr->internalRep.longValue) {
case 0L: case 1L:
@@ -1419,26 +1363,50 @@ SetBooleanFromAny(interp, objPtr)
}
goto badBoolean;
}
- if (objPtr->typePtr == &tclWideIntType) {
- Tcl_WideInt w = objPtr->internalRep.wideValue;
- if (w == 0 || w == 1) {
- newBool = (int) w;
- goto numericBoolean;
- } else {
- goto badBoolean;
- }
+#ifdef BIGNUM_AUTO_NARROW
+ if (objPtr->typePtr == &tclBignumType) {
+ goto badBoolean;
+ }
+#else
+ /* TODO: Consider tests to discover values 0 and 1 while preserving
+ * pure bignum. For now, pass through string rep. */
+#endif
+#ifndef NO_WIDE_TYPE
+ /* TODO: Consider tests to discover values 0 and 1 while preserving
+ * pure wide. For now, pass through string rep. */
+#endif
+ if (objPtr->typePtr == &tclDoubleType) {
+ goto badBoolean;
}
}
- /*
- * Parse the string as a boolean. We use an implementation here that
- * doesn't report errors in interp if interp is NULL.
- */
+ if (ParseBoolean(objPtr) == TCL_OK) {
+ return TCL_OK;
+ }
+
+ badBoolean:
+ if (interp != NULL) {
+ int length;
+ char *str = Tcl_GetStringFromObj(objPtr, &length);
+ Tcl_Obj *msg =
+ Tcl_NewStringObj("expected boolean value but got \"", -1);
+ TclAppendLimitedToObj(msg, str, length, 50, "");
+ Tcl_AppendToObj(msg, "\"", -1);
+ Tcl_SetObjResult(interp, msg);
+ }
+ return TCL_ERROR;
+}
+
+static int
+ParseBoolean(objPtr)
+ register Tcl_Obj *objPtr; /* The object to parse/convert. */
+{
+ int i, length, newBool;
+ char lowerCase[6], *str = Tcl_GetStringFromObj(objPtr, &length);
- str = Tcl_GetStringFromObj(objPtr, &length);
if ((length == 0) || (length > 5)) {
/* longest valid boolean string rep. is "false" */
- goto badBoolean;
+ return TCL_ERROR;
}
switch (str[0]) {
@@ -1447,13 +1415,13 @@ SetBooleanFromAny(interp, objPtr)
newBool = 0;
goto numericBoolean;
}
- goto badBoolean;
+ return TCL_ERROR;
case '1':
if (length == 1) {
newBool = 1;
goto numericBoolean;
}
- goto badBoolean;
+ return TCL_ERROR;
}
/*
@@ -1473,7 +1441,7 @@ SetBooleanFromAny(interp, objPtr)
lowerCase[i] = c;
break;
default:
- goto badBoolean;
+ return TCL_ERROR;
}
}
lowerCase[length] = 0;
@@ -1486,28 +1454,28 @@ SetBooleanFromAny(interp, objPtr)
newBool = 1;
goto goodBoolean;
}
- goto badBoolean;
+ return TCL_ERROR;
case 'n':
if (strncmp(lowerCase, "no", (size_t) length) == 0) {
newBool = 0;
goto goodBoolean;
}
- goto badBoolean;
+ return TCL_ERROR;
case 't':
if (strncmp(lowerCase, "true", (size_t) length) == 0) {
newBool = 1;
goto goodBoolean;
}
- goto badBoolean;
+ return TCL_ERROR;
case 'f':
if (strncmp(lowerCase, "false", (size_t) length) == 0) {
newBool = 0;
goto goodBoolean;
}
- goto badBoolean;
+ return TCL_ERROR;
case 'o':
if (length < 2) {
- goto badBoolean;
+ return TCL_ERROR;
}
if (strncmp(lowerCase, "on", (size_t) length) == 0) {
newBool = 1;
@@ -1516,9 +1484,9 @@ SetBooleanFromAny(interp, objPtr)
newBool = 0;
goto goodBoolean;
}
- goto badBoolean;
+ return TCL_ERROR;
default:
- goto badBoolean;
+ return TCL_ERROR;
}
/*
@@ -1533,17 +1501,6 @@ SetBooleanFromAny(interp, objPtr)
objPtr->typePtr = &tclBooleanType;
return TCL_OK;
- badBoolean:
- if (interp != NULL) {
- Tcl_Obj *msg =
- Tcl_NewStringObj("expected boolean value but got \"", -1);
- str = Tcl_GetStringFromObj(objPtr, &length);
- TclAppendLimitedToObj(msg, str, length, 50, "");
- Tcl_AppendToObj(msg, "\"", -1);
- Tcl_SetObjResult(interp, msg);
- }
- return TCL_ERROR;
-
numericBoolean:
TclFreeIntRep(objPtr);
objPtr->internalRep.longValue = newBool;
@@ -1712,29 +1669,36 @@ Tcl_GetDoubleFromObj(interp, objPtr, dblPtr)
register Tcl_Obj *objPtr; /* The object from which to get a double. */
register double *dblPtr; /* Place to store resulting double. */
{
- register int result;
-
- if (objPtr->typePtr == &tclIntType) {
- *dblPtr = objPtr->internalRep.longValue;
- return TCL_OK;
- } else if (objPtr->typePtr == &tclWideIntType) {
- *dblPtr = (double) objPtr->internalRep.wideValue;
- return TCL_OK;
- } else if (objPtr->typePtr != &tclDoubleType) {
- result = SetDoubleFromAny(interp, objPtr);
- if (result != TCL_OK) {
- return TCL_ERROR;
+ do {
+ if (objPtr->typePtr == &tclDoubleType) {
+ if (TclIsNaN(objPtr->internalRep.doubleValue)) {
+ if (interp != NULL) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "floating point value is Not a Number", -1));
+ }
+ return TCL_ERROR;
+ }
+ *dblPtr = (double) objPtr->internalRep.doubleValue;
+ return TCL_OK;
}
- }
- if (IS_NAN(objPtr->internalRep.doubleValue)) {
- if (interp != NULL) {
- Tcl_SetObjResult(interp, Tcl_NewStringObj(
- "floating point value is Not a Number", -1));
+ if (objPtr->typePtr == &tclIntType) {
+ *dblPtr = objPtr->internalRep.longValue;
+ return TCL_OK;
}
- return TCL_ERROR;
- }
- *dblPtr = objPtr->internalRep.doubleValue;
- return TCL_OK;
+ if (objPtr->typePtr == &tclBignumType) {
+ mp_int big;
+ UNPACK_BIGNUM( objPtr, big );
+ *dblPtr = TclBignumToDouble( &big );
+ return TCL_OK;
+ }
+#ifndef NO_WIDE_TYPE
+ if (objPtr->typePtr == &tclWideIntType) {
+ *dblPtr = (double) objPtr->internalRep.wideValue;
+ return TCL_OK;
+ }
+#endif
+ } while (SetDoubleFromAny(interp, objPtr) == TCL_OK);
+ return TCL_ERROR;
}
/*
@@ -1762,66 +1726,8 @@ SetDoubleFromAny(interp, objPtr)
Tcl_Interp *interp; /* Used for error reporting if not NULL. */
register Tcl_Obj *objPtr; /* The object to convert. */
{
- CONST char *string, *end;
- double newDouble;
- int length;
-
- /*
- * Get the string representation. Make it up-to-date if necessary.
- */
-
- string = Tcl_GetStringFromObj(objPtr, &length);
-
- /*
- * Now parse "objPtr"s string as an double. Numbers can't have embedded
- * NULLs. We use an implementation here that doesn't report errors in
- * interp if interp is NULL.
- */
-
- errno = 0;
- newDouble = TclStrToD(string, &end);
- if (end == string) {
- badDouble:
- if (interp != NULL) {
- Tcl_Obj *msg = Tcl_NewStringObj(
- "expected floating-point number but got \"", -1);
- TclAppendLimitedToObj(msg, string, length, 50, "");
- Tcl_AppendToObj(msg, "\"", -1);
- Tcl_SetObjResult(interp, msg);
- }
- return TCL_ERROR;
- }
-
- /*
- * Make sure that the string has no garbage after the end of the double.
- */
-
- while ((end < (string+length))
- && isspace(UCHAR(*end))) { /* INTL: ISO space. */
- end++;
- }
- if (end != (string+length)) {
- goto badDouble;
- }
-
- if (errno != 0 && errno != ERANGE) {
- if (interp != NULL) {
- TclExprFloatError(interp, newDouble);
- }
- return TCL_ERROR;
- }
-
- /*
- * The conversion to double succeeded. Free the old internalRep before
- * setting the new one. We do this as late as possible to allow the
- * conversion code, in particular Tcl_GetStringFromObj, to use that old
- * internalRep.
- */
-
- TclFreeIntRep(objPtr);
- objPtr->internalRep.doubleValue = newDouble;
- objPtr->typePtr = &tclDoubleType;
- return TCL_OK;
+ return TclParseNumber( interp, objPtr, "floating-point number",
+ NULL, -1, NULL, 0);
}
/*
@@ -1976,44 +1882,21 @@ Tcl_GetIntFromObj(interp, objPtr, intPtr)
register Tcl_Obj *objPtr; /* The object from which to get a int. */
register int *intPtr; /* Place to store resulting int. */
{
- int result;
- Tcl_WideInt w = 0;
-
- /*
- * If the object isn't already an integer of any width, try to convert it
- * to one.
- */
-
- if (objPtr->typePtr != &tclIntType && objPtr->typePtr != &tclWideIntType) {
- result = SetIntOrWideFromAny(interp, objPtr);
- if (result != TCL_OK) {
- return result;
- }
- }
-
- /*
- * Object should now be either int or wide. Get its value.
- */
+ long l;
-#ifndef TCL_WIDE_INT_IS_LONG
- if (objPtr->typePtr == &tclWideIntType) {
- w = objPtr->internalRep.wideValue;
- } else
-#endif
- {
- w = Tcl_LongAsWide(objPtr->internalRep.longValue);
+ if (Tcl_GetLongFromObj(interp, objPtr, &l) != TCL_OK) {
+ return TCL_ERROR;
}
-
- if ((LLONG_MAX > UINT_MAX)
- && ((w > UINT_MAX) || (w < -(Tcl_WideInt)UINT_MAX))) {
+ if ((ULONG_MAX > UINT_MAX) && ((l > UINT_MAX) || (l < -(long)UINT_MAX))) {
if (interp != NULL) {
- Tcl_SetObjResult(interp, Tcl_NewStringObj(
- "integer value too large to represent as non-long integer",
- -1));
+ CONST char *s
+ = "integer value too large to represent as non-long integer";
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(s, -1));
+ Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", s, (char *) NULL);
}
return TCL_ERROR;
}
- *intPtr = (int)w;
+ *intPtr = (int)l;
return TCL_OK;
}
@@ -2038,144 +1921,8 @@ SetIntFromAny(interp, objPtr)
Tcl_Interp* interp; /* Tcl interpreter */
Tcl_Obj* objPtr; /* Pointer to the object to convert */
{
- int result;
-
- result = SetIntOrWideFromAny(interp, objPtr);
- if (result != TCL_OK) {
- return result;
- }
- if (objPtr->typePtr != &tclIntType) {
- if (interp != NULL) {
- CONST char *s = "integer value too large to represent";
- Tcl_SetObjResult(interp, Tcl_NewStringObj(s, -1));
- Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", s, (char *) NULL);
- }
- return TCL_ERROR;
- }
- return TCL_OK;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * SetIntOrWideFromAny --
- *
- * Attempt to generate an integer internal form for the Tcl object
- * "objPtr".
- *
- * Results:
- * The return value is a standard object Tcl result. If an error occurs
- * during conversion, an error message is left in the interpreter's
- * result unless "interp" is NULL.
- *
- * Side effects:
- * If no error occurs, an int is stored as "objPtr"s internal
- * representation.
- *
- *----------------------------------------------------------------------
- */
-
-static int
-SetIntOrWideFromAny(interp, objPtr)
- Tcl_Interp *interp; /* Used for error reporting if not NULL. */
- register Tcl_Obj *objPtr; /* The object to convert. */
-{
- char *string, *end;
- int length;
- register char *p;
- unsigned long newLong;
- int isNegative = 0;
-
- /*
- * Get the string representation. Make it up-to-date if necessary.
- */
-
- p = string = Tcl_GetStringFromObj(objPtr, &length);
-
- /*
- * Now parse "objPtr"s string as an int. We use an implementation here
- * that doesn't report errors in interp if interp is NULL. Note: use
- * strtoul instead of strtol for integer conversions to allow full-size
- * unsigned numbers. We parse the leading space and sign ourselves so we
- * can tell the difference between apparently positive and negative
- * values.
- */
-
- errno = 0;
- for (; isspace(UCHAR(*p)) ; p++) { /* INTL: ISO space. */
- /* Empty loop body. */
- }
- if (*p == '-') {
- isNegative = 1;
- p++;
- } else if (*p == '+') {
- p++;
- }
- if (!isdigit(UCHAR(*p))) {
- badInteger:
- if (interp != NULL) {
- Tcl_Obj *msg =
- Tcl_NewStringObj("expected integer but got \"", -1);
- TclAppendLimitedToObj(msg, string, length, 50, "");
- Tcl_AppendToObj(msg, "\"", -1);
- Tcl_SetObjResult(interp, msg);
- TclCheckBadOctal(interp, string);
- }
- return TCL_ERROR;
- }
- newLong = strtoul(p, &end, 0);
- if (end == p) {
- goto badInteger;
- }
-
- /*
- * Make sure that the string has no garbage after the end of the int.
- */
-
- while ((end < (string+length))
- && isspace(UCHAR(*end))) { /* INTL: ISO space. */
- end++;
- }
- if (end != (string+length)) {
- goto badInteger;
- }
-
- if (errno == ERANGE) {
- if (interp != NULL) {
- CONST char *s = "integer value too large to represent";
- Tcl_SetObjResult(interp, Tcl_NewStringObj(s, -1));
- Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", s, (char *) NULL);
- }
- return TCL_ERROR;
- }
-
- /*
- * The conversion to int succeeded. Free the old internalRep before
- * setting the new one. We do this as late as possible to allow the
- * conversion code, in particular Tcl_GetStringFromObj, to use that old
- * internalRep.
- */
-
- TclFreeIntRep(objPtr);
-#ifndef TCL_WIDE_INT_IS_LONG
- /*
- * If the resulting integer will exceed the range of a long, put it into a
- * wide instead. (Tcl Bug #868489)
- */
-
- if ((isNegative && newLong > (unsigned long) (LONG_MAX) + 1)
- || (!isNegative && newLong > LONG_MAX)) {
- objPtr->internalRep.wideValue =
- (isNegative ? -(Tcl_WideInt)newLong : (Tcl_WideInt)newLong);
- objPtr->typePtr = &tclWideIntType;
- } else
-#endif
- {
- objPtr->internalRep.longValue =
- (isNegative ? -(long)newLong : (long)newLong);
- objPtr->typePtr = &tclIntType;
- }
- return TCL_OK;
+ long l;
+ return Tcl_GetLongFromObj(interp, objPtr, &l);
}
/*
@@ -2392,142 +2139,81 @@ Tcl_GetLongFromObj(interp, objPtr, longPtr)
register Tcl_Obj *objPtr; /* The object from which to get a long. */
register long *longPtr; /* Place to store resulting long. */
{
- register int result;
-
- if (objPtr->typePtr != &tclIntType
- && objPtr->typePtr != &tclWideIntType) {
- result = SetIntOrWideFromAny(interp, objPtr);
- if (result != TCL_OK) {
- return result;
+ do {
+ if (objPtr->typePtr == &tclIntType) {
+ *longPtr = objPtr->internalRep.longValue;
+ return TCL_OK;
}
- }
-
-#ifndef TCL_WIDE_INT_IS_LONG
- if (objPtr->typePtr == &tclWideIntType) {
- /*
- * If the object is already a wide integer, don't convert it. This
- * code allows for any integer in the range -ULONG_MAX to ULONG_MAX to
- * be converted to a long, ignoring overflow. The rule preserves
- * existing semantics for conversion of integers on input, but avoids
- * inadvertent demotion of wide integers to 32-bit ones in the
- * internal rep.
- */
+#ifndef NO_WIDE_TYPE
+ if (objPtr->typePtr == &tclWideIntType) {
+ /*
+ * We return any integer in the range -ULONG_MAX to ULONG_MAX
+ * converted to a long, ignoring overflow. The rule preserves
+ * existing semantics for conversion of integers on input, but
+ * avoids inadvertent demotion of wide integers to 32-bit ones
+ * in the internal rep.
+ */
- Tcl_WideInt w = objPtr->internalRep.wideValue;
- if (w >= -(Tcl_WideInt)(ULONG_MAX)
- && w <= (Tcl_WideInt)(ULONG_MAX)) {
- *longPtr = Tcl_WideAsLong(w);
- return TCL_OK;
- } else {
- if (interp != NULL) {
- Tcl_SetObjResult(interp, Tcl_NewStringObj(
- "integer value too large to represent", -1));
+ Tcl_WideInt w = objPtr->internalRep.wideValue;
+ if (w >= -(Tcl_WideInt)(ULONG_MAX)
+ && w <= (Tcl_WideInt)(ULONG_MAX)) {
+ *longPtr = Tcl_WideAsLong(w);
+ return TCL_OK;
}
- return TCL_ERROR;
+ goto tooLarge;
}
- }
#endif
-
- *longPtr = objPtr->internalRep.longValue;
- return TCL_OK;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * SetWideIntFromAny --
- *
- * Attempt to generate an integer internal form for the Tcl object
- * "objPtr".
- *
- * Results:
- * The return value is a standard object Tcl result. If an error occurs
- * during conversion, an error message is left in the interpreter's
- * result unless "interp" is NULL.
- *
- * Side effects:
- * If no error occurs, an int is stored as "objPtr"s internal
- * representation.
- *
- *----------------------------------------------------------------------
- */
-
-static int
-SetWideIntFromAny(interp, objPtr)
- Tcl_Interp *interp; /* Used for error reporting if not NULL. */
- register Tcl_Obj *objPtr; /* The object to convert. */
-{
-#ifndef TCL_WIDE_INT_IS_LONG
- char *string, *end;
- int length;
- register char *p;
- Tcl_WideInt newWide;
-
- /*
- * Get the string representation. Make it up-to-date if necessary.
- */
-
- p = string = Tcl_GetStringFromObj(objPtr, &length);
-
- /*
- * Now parse "objPtr"s string as an int. We use an implementation here
- * that doesn't report errors in interp if interp is NULL. Note: use
- * strtoull instead of strtoll for integer conversions to allow full-size
- * unsigned numbers.
- */
-
- errno = 0;
- newWide = strtoull(p, &end, 0);
- if (end == p) {
- badInteger:
- if (interp != NULL) {
- Tcl_Obj *msg =
- Tcl_NewStringObj("expected integer but got \"", -1);
- TclAppendLimitedToObj(msg, string, length, 50, "");
- Tcl_AppendToObj(msg, "\"", -1);
- Tcl_SetObjResult(interp, msg);
- TclCheckBadOctal(interp, string);
- }
- return TCL_ERROR;
- }
-
- /*
- * Make sure that the string has no garbage after the end of the int.
- */
-
- while ((end < (string+length))
- && isspace(UCHAR(*end))) { /* INTL: ISO space. */
- end++;
- }
- if (end != (string+length)) {
- goto badInteger;
- }
-
- if (errno == ERANGE) {
- if (interp != NULL) {
- CONST char *s = "integer value too large to represent";
- Tcl_SetObjResult(interp, Tcl_NewStringObj(s, -1));
- Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", s, (char *) NULL);
+ if (objPtr->typePtr == &tclDoubleType) {
+ if (interp != NULL) {
+ Tcl_Obj* msg =
+ Tcl_NewStringObj("expected integer but got \"", -1);
+ Tcl_AppendObjToObj(msg, objPtr);
+ Tcl_AppendToObj(msg, "\"", -1);
+ Tcl_SetObjResult(interp, msg);
+ }
+ return TCL_ERROR;
}
- return TCL_ERROR;
- }
- /*
- * The conversion to int succeeded. Free the old internalRep before
- * setting the new one. We do this as late as possible to allow the
- * conversion code, in particular Tcl_GetStringFromObj, to use that old
- * internalRep.
- */
-
- TclFreeIntRep(objPtr);
- objPtr->internalRep.wideValue = newWide;
-#else
- if (TCL_ERROR == SetIntFromAny(interp, objPtr)) {
- return TCL_ERROR;
- }
+ if (objPtr->typePtr == &tclBignumType) {
+ /* Must check for those bignum values that can fit in
+ * a long, even when auto-narrowing is enabled. Only those
+ * values in the signed long range get auto-narrowed to
+ * tclIntType, while all the values in the unsigned long
+ * range will fit in a long. */
+ mp_int big;
+ UNPACK_BIGNUM(objPtr, big);
+ if (big.used <= (CHAR_BIT * sizeof(long) + DIGIT_BIT - 1)
+ / DIGIT_BIT) {
+ unsigned long value = 0, numBytes = sizeof(long);
+ long scratch;
+ unsigned char *bytes = (unsigned char *)&scratch;
+ if (mp_to_unsigned_bin_n(&big, bytes, &numBytes) == MP_OKAY) {
+ while (numBytes-- > 0) {
+ value = (value << CHAR_BIT) | *bytes++;
+ }
+ if (big.sign) {
+ *longPtr = - (long) value;
+ } else {
+ *longPtr = (long) value;
+ }
+ return TCL_OK;
+ }
+ }
+#ifndef NO_WIDE_TYPE
+ tooLarge:
#endif
- objPtr->typePtr = &tclWideIntType;
- return TCL_OK;
+ if (interp != NULL) {
+ char *s = "integer value too large to represent";
+ Tcl_Obj* msg = Tcl_NewStringObj(s, -1);
+ Tcl_SetObjResult(interp, msg);
+ Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", s, (char *)NULL);
+ }
+ return TCL_ERROR;
+ }
+ } while (TclParseNumber(interp, objPtr, "integer", NULL, -1, NULL,
+ TCL_PARSE_INTEGER_ONLY)==TCL_OK);
+ return TCL_ERROR;
}
+#ifndef NO_WIDE_TYPE
/*
*----------------------------------------------------------------------
@@ -2548,7 +2234,6 @@ SetWideIntFromAny(interp, objPtr)
*----------------------------------------------------------------------
*/
-#ifndef TCL_WIDE_INT_IS_LONG
static void
UpdateStringOfWideInt(objPtr)
register Tcl_Obj *objPtr; /* Int object whose string rep to update. */
@@ -2570,7 +2255,7 @@ UpdateStringOfWideInt(objPtr)
memcpy(objPtr->bytes, buffer, len + 1);
objPtr->length = len;
}
-#endif /* TCL_WIDE_INT_IS_LONG */
+#endif /* !NO_WIDE_TYPE */
/*
*----------------------------------------------------------------------
@@ -2617,7 +2302,8 @@ Tcl_NewWideIntObj(wideValue)
{
register Tcl_Obj *objPtr;
- TclNewWideIntObj(objPtr, wideValue);
+ TclNewObj(objPtr);
+ Tcl_SetWideIntObj(objPtr, wideValue);
return objPtr;
}
#endif /* if TCL_MEM_DEBUG */
@@ -2669,10 +2355,7 @@ Tcl_DbNewWideIntObj(wideValue, file, line)
register Tcl_Obj *objPtr;
TclDbNewObj(objPtr, file, line);
- objPtr->bytes = NULL;
-
- objPtr->internalRep.wideValue = wideValue;
- objPtr->typePtr = &tclWideIntType;
+ Tcl_SetWideIntObj(objPtr, wideValue);
return objPtr;
}
@@ -2720,7 +2403,18 @@ Tcl_SetWideIntObj(objPtr, wideValue)
Tcl_Panic("Tcl_SetWideIntObj called with shared object");
}
- TclSetWideIntObj(objPtr, wideValue);
+ if ((wideValue >= (Tcl_WideInt) LONG_MIN)
+ && (wideValue <= (Tcl_WideInt) LONG_MAX)) {
+ TclSetLongObj(objPtr, (long) wideValue);
+ } else {
+#ifndef NO_WIDE_TYPE
+ TclSetWideIntObj(objPtr, wideValue);
+#else
+ mp_int big;
+ TclBNInitBignumFromWideInt(&big, wideValue);
+ Tcl_SetBignumObj(objPtr, &big);
+#endif
+ }
}
/*
@@ -2750,17 +2444,61 @@ Tcl_GetWideIntFromObj(interp, objPtr, wideIntPtr)
register Tcl_Obj *objPtr; /* Object from which to get a wide int. */
register Tcl_WideInt *wideIntPtr; /* Place to store resulting long. */
{
- register int result;
-
- if (objPtr->typePtr == &tclWideIntType) {
- *wideIntPtr = objPtr->internalRep.wideValue;
- return TCL_OK;
- }
- result = SetWideIntFromAny(interp, objPtr);
- if (result == TCL_OK) {
- *wideIntPtr = objPtr->internalRep.wideValue;
- }
- return result;
+ do {
+#ifndef NO_WIDE_TYPE
+ if (objPtr->typePtr == &tclWideIntType) {
+ *wideIntPtr = objPtr->internalRep.wideValue;
+ return TCL_OK;
+ }
+#endif
+ if (objPtr->typePtr == &tclIntType) {
+ *wideIntPtr = (Tcl_WideInt) objPtr->internalRep.longValue;
+ return TCL_OK;
+ }
+ if (objPtr->typePtr == &tclDoubleType) {
+ if (interp != NULL) {
+ Tcl_Obj* msg =
+ Tcl_NewStringObj("expected integer but got \"", -1);
+ Tcl_AppendObjToObj(msg, objPtr);
+ Tcl_AppendToObj(msg, "\"", -1);
+ Tcl_SetObjResult(interp, msg);
+ }
+ return TCL_ERROR;
+ }
+ if (objPtr->typePtr == &tclBignumType) {
+ /* Must check for those bignum values that can fit in
+ * a Tcl_WideInt, even when auto-narrowing is enabled. */
+ mp_int big;
+ UNPACK_BIGNUM(objPtr, big);
+ if (big.used <= (CHAR_BIT * sizeof(Tcl_WideInt) + DIGIT_BIT - 1)
+ / DIGIT_BIT) {
+ Tcl_WideUInt value = 0;
+ unsigned long numBytes = sizeof(Tcl_WideInt);
+ Tcl_WideInt scratch;
+ unsigned char *bytes = (unsigned char *)&scratch;
+ if (mp_to_unsigned_bin_n(&big, bytes, &numBytes) == MP_OKAY) {
+ while (numBytes-- > 0) {
+ value = (value << CHAR_BIT) | *bytes++;
+ }
+ if (big.sign) {
+ *wideIntPtr = - (Tcl_WideInt) value;
+ } else {
+ *wideIntPtr = (Tcl_WideInt) value;
+ }
+ return TCL_OK;
+ }
+ }
+ if (interp != NULL) {
+ char *s = "integer value too large to represent";
+ Tcl_Obj* msg = Tcl_NewStringObj(s, -1);
+ Tcl_SetObjResult(interp, msg);
+ Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", s, (char *)NULL);
+ }
+ return TCL_ERROR;
+ }
+ } while (TclParseNumber(interp, objPtr, "integer", NULL, -1, NULL,
+ TCL_PARSE_INTEGER_ONLY)==TCL_OK);
+ return TCL_ERROR;
}
/*
@@ -2783,6 +2521,9 @@ FreeBignum(Tcl_Obj *objPtr)
UNPACK_BIGNUM(objPtr, toFree);
mp_clear(&toFree);
+ if (objPtr->internalRep.ptrAndLongRep.value < 0) {
+ ckfree((char *)objPtr->internalRep.ptrAndLongRep.ptr);
+ }
}
/*
@@ -2814,129 +2555,7 @@ DupBignum(srcPtr, copyPtr)
if (mp_init_copy(&bignumCopy, &bignumVal) != MP_OKAY) {
Tcl_Panic("initialization failure in DupBignum");
}
- PACK_BIGNUM(bignumVal, copyPtr);
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * SetBignumFromAny --
- *
- * This procedure interprets a Tcl_Obj as a bignum and sets the internal
- * representation accordingly.
- *
- * Results:
- * Returns a standard Tcl status. If conversion fails, an error message
- * is left in the interpreter result.
- *
- * Side effects:
- * The bignum internal representation is packed into the object.
- *
- *----------------------------------------------------------------------
- */
-
-static int
-SetBignumFromAny(interp, objPtr)
- Tcl_Interp* interp;
- Tcl_Obj* objPtr;
-{
- CONST char* stringVal;
- CONST char* p;
- int length;
- int signum = MP_ZPOS;
- int radix = 10;
- int status;
- mp_int bignumVal;
-
- if (objPtr->typePtr == &tclIntType) {
-
- /*
- * If the number already contains an integer, simply widen it to a
- * bignum.
- */
-
- TclBNInitBignumFromLong(&bignumVal, objPtr->internalRep.longValue);
- } else {
-
- /*
- * The number doesn't contain an integer. Convert its string rep to a
- * bignum, handling 0XXX and 0xXXX notation
- */
-
- stringVal = Tcl_GetStringFromObj(objPtr, &length);
- p = stringVal;
-
- /*
- * Pull off the signum
- */
-
- if (*p == '+') {
- ++p;
- } else if (*p == '-') {
- ++p;
- signum = MP_NEG;
- }
-
- /*
- * Handle octal and hexadecimal
- */
-
- if (*p == '0') {
- ++p;
- if (*p == 'x' || *p == 'X') {
- ++p;
- radix = 16;
- } else {
- --p;
- radix = 8;
- }
- }
-
- /* Convert the value */
-
- if (mp_init(&bignumVal) != MP_OKAY) {
- Tcl_Panic("initialization failure in SetBignumFromAny");
- }
- status = mp_read_radix(&bignumVal, p, radix);
- switch (status) {
- case MP_MEM:
- Tcl_Panic("out of memory in SetBignumFromAny");
- case MP_OKAY:
- break;
- default:
- if (interp != NULL) {
- Tcl_Obj* msg = Tcl_NewStringObj(
- "expected integer but got \"", -1);
- TclAppendLimitedToObj(msg, stringVal, length, 50, "");
- Tcl_AppendToObj(msg, "\"", -1);
- Tcl_SetObjResult(interp, msg);
- TclCheckBadOctal(interp, stringVal);
- }
- mp_clear(&bignumVal);
- return TCL_ERROR;
- }
-
- /* Conversion to bignum succeeded. Make sure that everything fits. */
-
- if (bignumVal.alloc > 0x7fff) {
- Tcl_Obj* msg =
- Tcl_NewStringObj("integer value too large to represent",-1);
- Tcl_SetObjResult(interp, msg);
- mp_clear(&bignumVal);
- return TCL_ERROR;
- }
- }
-
- /*
- * Conversion succeeded. Clean up the old internal rep and store the new
- * one.
- */
-
- TclFreeIntRep(objPtr);
- bignumVal.sign = signum;
- PACK_BIGNUM(bignumVal, objPtr);
- objPtr->typePtr = &tclBignumType;
- return TCL_OK;
+ PACK_BIGNUM(bignumCopy, copyPtr);
}
/*
@@ -2970,6 +2589,23 @@ UpdateStringOfBignum(Tcl_Obj* objPtr)
if (status != MP_OKAY) {
Tcl_Panic("radix size failure in UpdateStringOfBignum");
}
+ if (size == 3
+#ifndef BIGNUM_AUTO_NARROW
+ && bignumVal.used > 1
+#endif
+ ) {
+ /*
+ * mp_radix_size() returns 3 when more than INT_MAX bytes would
+ * be needed to hold the string rep (because mp_radix_size
+ * ignores integer overflow issues). When we know the string
+ * rep will be more than 3, we can conclude the string rep would
+ * overflow our string length limits.
+ *
+ * Note that so long as we enforce our bignums to the size that
+ * fits in a packed bignum, this branch will never be taken.
+ */
+ Tcl_Panic("UpdateStringOfBignum: string length limit exceeded");
+ }
stringVal = Tcl_Alloc((size_t) size);
status = mp_toradix_n(&bignumVal, stringVal, 10, size);
if (status != MP_OKAY) {
@@ -3007,16 +2643,8 @@ Tcl_Obj *
Tcl_NewBignumObj(mp_int* bignumValue)
{
Tcl_Obj* objPtr;
-
TclNewObj(objPtr);
- PACK_BIGNUM(*bignumValue, objPtr);
- objPtr->typePtr=&tclBignumType;
- objPtr->bytes = NULL;
-
- /* Clear with mp_init; mp_clear would overwrite the digit array. */
-
- mp_init(bignumValue);
-
+ Tcl_SetBignumObj(objPtr, bignumValue);
return objPtr;
}
#endif
@@ -3046,15 +2674,7 @@ Tcl_DbNewBignumObj(mp_int* bignumValue, CONST char* file, int line)
Tcl_Obj* objPtr;
TclDbNewObj(objPtr, file, line);
- objPtr->bytes = NULL;
- PACK_BIGNUM(*bignumValue, objPtr);
- objPtr->typePtr = &tclBignumType;
- objPtr->bytes = NULL;
-
- /* Clear with mp_init; mp_clear would overwrite the digit array. */
-
- mp_init(bignumValue);
-
+ Tcl_SetBignumObj(objPtr, bignumValue);
return objPtr;
}
#else
@@ -3068,6 +2688,80 @@ Tcl_DbNewBignumObj(mp_int* bignumValue, CONST char* file, int line)
/*
*----------------------------------------------------------------------
*
+ * GetBignumFromObj --
+ *
+ * This procedure retrieves a 'bignum' value from a Tcl object,
+ * converting the object if necessary. Either copies or transfers
+ * the mp_int value depending on the copy flag value passed in.
+ *
+ * Results:
+ * Returns TCL_OK if the conversion is successful, TCL_ERROR otherwise.
+ *
+ * Side effects:
+ * A copy of bignum is stored in *bignumValue, which is expected to be
+ * uninitialized or cleared. If conversion fails, and the 'interp'
+ * argument is not NULL, an error message is stored in the interpreter
+ * result.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+GetBignumFromObj(
+ Tcl_Interp* interp, /* Tcl interpreter for error reporting */
+ Tcl_Obj* objPtr, /* Object to read */
+ int copy, /* Whether to copy the returned bignum value */
+ mp_int* bignumValue) /* Returned bignum value. */
+{
+ do {
+ if (objPtr->typePtr == &tclBignumType) {
+ if (copy) {
+ mp_int temp;
+ UNPACK_BIGNUM(objPtr, temp);
+ mp_init_copy(bignumValue, &temp);
+ } else {
+ if (Tcl_IsShared(objPtr)) {
+ Tcl_Panic("Tcl_GetBignumAndClearObj called on shared Tcl_Obj");
+ }
+ UNPACK_BIGNUM(objPtr, *bignumValue);
+ objPtr->internalRep.ptrAndLongRep.ptr = NULL;
+ objPtr->internalRep.ptrAndLongRep.value = 0;
+ objPtr->typePtr = NULL;
+ if (objPtr->bytes == NULL) {
+ TclInitStringRep(objPtr, NULL, 0);
+ }
+ }
+ return TCL_OK;
+ }
+ if (objPtr->typePtr == &tclIntType) {
+ TclBNInitBignumFromLong(bignumValue, objPtr->internalRep.longValue);
+ return TCL_OK;
+ }
+#ifndef NO_WIDE_TYPE
+ if (objPtr->typePtr == &tclWideIntType) {
+ TclBNInitBignumFromWideInt(bignumValue,
+ objPtr->internalRep.wideValue);
+ return TCL_OK;
+ }
+#endif
+ if (objPtr->typePtr == &tclDoubleType) {
+ if (interp != NULL) {
+ Tcl_Obj* msg =
+ Tcl_NewStringObj("expected integer but got \"", -1);
+ Tcl_AppendObjToObj(msg, objPtr);
+ Tcl_AppendToObj(msg, "\"", -1);
+ Tcl_SetObjResult(interp, msg);
+ }
+ return TCL_ERROR;
+ }
+ } while (TclParseNumber(interp, objPtr, "integer", NULL, -1, NULL,
+ TCL_PARSE_INTEGER_ONLY)==TCL_OK);
+ return TCL_ERROR;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* Tcl_GetBignumFromObj --
*
* This procedure retrieves a 'bignum' value from a Tcl object,
@@ -3083,9 +2777,10 @@ Tcl_DbNewBignumObj(mp_int* bignumValue, CONST char* file, int line)
* result.
*
* It is expected that the caller will NOT have invoked mp_init on the
- * bignum value before passing it in. The raw value of the object is
- * returned, and Tcl owns that memory, so the caller should NOT invoke
- * mp_clear afterwards.
+ * bignum value before passing it in. Tcl will initialize the mp_int
+ * as it sets the value. The value is a copy of the value in objPtr,
+ * so it becomes the responsibility of the caller to call mp_clear on
+ * it.
*
*----------------------------------------------------------------------
*/
@@ -3096,16 +2791,42 @@ Tcl_GetBignumFromObj(
Tcl_Obj* objPtr, /* Object to read */
mp_int* bignumValue) /* Returned bignum value. */
{
- mp_int temp;
+ return GetBignumFromObj(interp, objPtr, 1, bignumValue);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_GetBignumAndClearObj --
+ *
+ * This procedure retrieves a 'bignum' value from a Tcl object,
+ * converting the object if necessary.
+ *
+ * Results:
+ * Returns TCL_OK if the conversion is successful, TCL_ERROR otherwise.
+ *
+ * Side effects:
+ * A copy of bignum is stored in *bignumValue, which is expected to be
+ * uninitialized or cleared. If conversion fails, an the 'interp'
+ * argument is not NULL, an error message is stored in the interpreter
+ * result.
+ *
+ * It is expected that the caller will NOT have invoked mp_init on the
+ * bignum value before passing it in. Tcl will initialize the mp_int
+ * as it sets the value. The value is transferred from the internals
+ * of objPtr to the caller, passing responsibility of the caller to
+ * call mp_clear on it. The objPtr is cleared to hold an empty value.
+ *
+ *----------------------------------------------------------------------
+ */
- if (objPtr->typePtr != &tclBignumType) {
- if (SetBignumFromAny(interp, objPtr) != TCL_OK) {
- return TCL_ERROR;
- }
- }
- UNPACK_BIGNUM(objPtr, temp);
- mp_init_copy(bignumValue, &temp);
- return TCL_OK;
+int
+Tcl_GetBignumAndClearObj(
+ Tcl_Interp* interp, /* Tcl interpreter for error reporting */
+ Tcl_Obj* objPtr, /* Object to read */
+ mp_int* bignumValue) /* Returned bignum value. */
+{
+ return GetBignumFromObj(interp, objPtr, 0, bignumValue);
}
/*
@@ -3133,14 +2854,132 @@ Tcl_SetBignumObj(
if (Tcl_IsShared(objPtr)) {
Tcl_Panic("Tcl_SetBignumObj called with shared object");
}
+#ifdef BIGNUM_AUTO_NARROW
+ if (bignumValue->used
+ <= (CHAR_BIT * sizeof(long) + DIGIT_BIT - 1) / DIGIT_BIT) {
+ unsigned long value = 0, numBytes = sizeof(long);
+ long scratch;
+ unsigned char *bytes = (unsigned char *)&scratch;
+ if (mp_to_unsigned_bin_n(bignumValue, bytes, &numBytes) != MP_OKAY) {
+ goto tooLargeForLong;
+ }
+ while (numBytes-- > 0) {
+ value = (value << CHAR_BIT) | *bytes++;
+ }
+ if (value > (((~(unsigned long)0) >> 1) + bignumValue->sign)) {
+ goto tooLargeForLong;
+ }
+ if (bignumValue->sign) {
+ TclSetLongObj(objPtr, -(long)value);
+ } else {
+ TclSetLongObj(objPtr, (long)value);
+ }
+ mp_clear(bignumValue);
+ return;
+ }
+ tooLargeForLong:
+#ifndef NO_WIDE_TYPE
+ if (bignumValue->used
+ <= (CHAR_BIT * sizeof(Tcl_WideInt) + DIGIT_BIT - 1) / DIGIT_BIT) {
+ Tcl_WideUInt value = 0;
+ unsigned long numBytes = sizeof(Tcl_WideInt);
+ Tcl_WideInt scratch;
+ unsigned char *bytes = (unsigned char *)&scratch;
+ if (mp_to_unsigned_bin_n(bignumValue, bytes, &numBytes) != MP_OKAY) {
+ goto tooLargeForWide;
+ }
+ while (numBytes-- > 0) {
+ value = (value << CHAR_BIT) | *bytes++;
+ }
+ if (value > (((~(Tcl_WideUInt)0) >> 1) + bignumValue->sign)) {
+ goto tooLargeForWide;
+ }
+ if (bignumValue->sign) {
+ TclSetWideIntObj(objPtr, -(Tcl_WideInt)value);
+ } else {
+ TclSetWideIntObj(objPtr, (Tcl_WideInt)value);
+ }
+ mp_clear(bignumValue);
+ return;
+ }
+ tooLargeForWide:
+#endif
+#endif
+ TclInvalidateStringRep(objPtr);
TclFreeIntRep(objPtr);
+ TclSetBignumIntRep(objPtr, bignumValue);
+}
+
+void
+TclSetBignumIntRep(objPtr, bignumValue)
+ Tcl_Obj *objPtr;
+ mp_int *bignumValue;
+{
objPtr->typePtr = &tclBignumType;
PACK_BIGNUM(*bignumValue, objPtr);
- Tcl_InvalidateStringRep(objPtr);
- /* Clear the value with mp_init; mp_clear overwrites the digit array. */
+ /*
+ * Clear the mp_int value.
+ * Don't call mp_clear() because it would free the digit array
+ * we just packed into the Tcl_Obj.
+ */
- mp_init(bignumValue);
+ bignumValue->dp = NULL;
+ bignumValue->alloc = bignumValue->used = 0;
+ bignumValue->sign = MP_NEG;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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;
+ }
+#ifndef NO_WIDE_TYPE
+ if (objPtr->typePtr == &tclWideIntType) {
+ *typePtr = TCL_NUMBER_WIDE;
+ *clientDataPtr = &(objPtr->internalRep.wideValue);
+ return TCL_OK;
+ }
+#endif
+ 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;
+ }
+ } while (TCL_OK ==
+ TclParseNumber(interp, objPtr, "number", NULL, -1, NULL, 0));
+ return TCL_ERROR;
}
/*
diff --git a/generic/tclParseExpr.c b/generic/tclParseExpr.c
index b6f3548..d617300 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.27 2005/07/21 14:38:50 dkf Exp $
+ * RCS: @(#) $Id: tclParseExpr.c,v 1.28 2005/10/08 14:42:45 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.
*/
@@ -166,8 +151,6 @@ static int ParseCondExpr _ANSI_ARGS_((ParseInfo *infoPtr));
static int ParseEqualityExpr _ANSI_ARGS_((ParseInfo *infoPtr));
static int ParseLandExpr _ANSI_ARGS_((ParseInfo *infoPtr));
static int ParseLorExpr _ANSI_ARGS_((ParseInfo *infoPtr));
-static int ParseMaxDoubleLength _ANSI_ARGS_((CONST char *string,
- CONST char *end));
static int ParseMultiplyExpr _ANSI_ARGS_((ParseInfo *infoPtr));
static int ParsePrimaryExpr _ANSI_ARGS_((ParseInfo *infoPtr));
static int ParseRelationalExpr _ANSI_ARGS_((ParseInfo *infoPtr));
@@ -1589,7 +1572,6 @@ GetLexeme(infoPtr)
char c;
int offset, length, numBytes;
Tcl_Parse *parsePtr = infoPtr->parsePtr;
- Tcl_Interp *interp = parsePtr->interp;
Tcl_UniChar ch;
/*
@@ -1632,59 +1614,16 @@ GetLexeme(infoPtr)
c = *src;
if ((c != '+') && (c != '-')) {
CONST char *end = infoPtr->lastChar;
- if ((length = TclParseInteger(src, end-src))) {
- /*
- * First length bytes look like an integer. Verify by attempting
- * the conversion to the largest integer we have.
- */
-
- int code;
- Tcl_WideInt wide;
- Tcl_Obj *value = Tcl_NewStringObj(src, length);
-
- Tcl_IncrRefCount(value);
- code = Tcl_GetWideIntFromObj(interp, value, &wide);
- Tcl_DecrRefCount(value);
- if (code == TCL_ERROR) {
- parsePtr->errorType = TCL_PARSE_BAD_NUMBER;
- return TCL_ERROR;
- }
- infoPtr->lexeme = LITERAL;
- infoPtr->start = src;
- infoPtr->size = length;
- infoPtr->next = (src + length);
- parsePtr->term = infoPtr->next;
- return TCL_OK;
- } else if ((length = ParseMaxDoubleLength(src, end))) {
- /*
- * There are length characters that could be a double. Let
- * strtod() tells us for sure. Need a writable copy so we can set
- * an terminating NULL to keep strtod from scanning too far.
- */
-
- char *startPtr;
- CONST char *termPtr;
- double doubleValue;
- Tcl_DString toParse;
-
- errno = 0;
- Tcl_DStringInit(&toParse);
- startPtr = Tcl_DStringAppend(&toParse, src, length);
- doubleValue = TclStrToD(startPtr, &termPtr);
- Tcl_DStringFree(&toParse);
- if (termPtr != startPtr) {
- /*
- * startPtr was the start of a valid double, copied from src.
- */
-
+ CONST char* end2;
+ int code = TclParseNumber(NULL, NULL, NULL,
+ src, (unsigned)(end-src), &end2, 0);
+ if ( code == TCL_OK ) {
+ length = end2-src;
+ if ( length > 0 ) {
infoPtr->lexeme = LITERAL;
infoPtr->start = src;
- if ((termPtr - startPtr) > length) {
- infoPtr->size = length;
- } else {
- infoPtr->size = (termPtr - startPtr);
- }
- infoPtr->next = src + infoPtr->size;
+ infoPtr->size = length;
+ infoPtr->next = (src + length);
parsePtr->term = infoPtr->next;
return TCL_OK;
}
@@ -1932,6 +1871,7 @@ GetLexeme(infoPtr)
}
}
+#if 0
/*
*----------------------------------------------------------------------
*
@@ -1991,55 +1931,7 @@ TclParseInteger(string, numBytes)
}
return 0;
}
-
-/*
- *----------------------------------------------------------------------
- *
- * ParseMaxDoubleLength --
- *
- * Scans a sequence of bytes checking that the characters could be in a
- * string rep of a double.
- *
- * Results:
- * Returns the number of bytes starting with string, running to, but not
- * including end, all of which could be part of a string rep. of a
- * double. Only character identity is used, no actual parsing is done.
- *
- * The legal bytes are '0' - '9', 'A' - 'F', 'a' - 'f', '.', '+', '-',
- * 'i', 'I', 'n', 'N', 'p', 'P', 'x', and 'X'. This covers the values
- * "Inf" and "Nan" as well as the decimal and hexadecimal representations
- * recognized by a C99-compliant strtod().
- *
- * Side effects:
- * None.
- *
- *----------------------------------------------------------------------
- */
-
-static int
-ParseMaxDoubleLength(string, end)
- register CONST char *string;/* The string to examine. */
- CONST char *end; /* Point to the first character past the end
- * of the string we are examining. */
-{
- CONST char *p = string;
- while (p < end) {
- switch (*p) {
- case '0': case '1': case '2': case '3': case '4': case '5':
- case '6': case '7': case '8': case '9': case 'A': case 'B':
- case 'C': case 'D': case 'E': case 'F': case 'I': case 'N':
- case 'P': case 'X': case 'a': case 'b': case 'c': case 'd':
- case 'e': case 'f': case 'i': case 'n': case 'p': case 'x':
- case '.': case '+': case '-': case '(': case ' ': case ')':
- p++;
- break;
- default:
- goto done;
- }
- }
- done:
- return (p - string);
-}
+#endif
/*
*----------------------------------------------------------------------
diff --git a/generic/tclProc.c b/generic/tclProc.c
index b184c8a..b6f73e7 100644
--- a/generic/tclProc.c
+++ b/generic/tclProc.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: tclProc.c,v 1.80 2005/09/15 16:40:02 dgp Exp $
+ * RCS: @(#) $Id: tclProc.c,v 1.81 2005/10/08 14:42:45 dgp Exp $
*/
#include "tclInt.h"
@@ -669,8 +669,12 @@ TclObjGetFrame(interp, objPtr, framePtrPtr)
if (level < 0) {
goto levelError;
}
- } else if (objPtr->typePtr == &tclIntType ||
- objPtr->typePtr == &tclWideIntType) {
+ /* TODO: Consider skipping the typePtr checks */
+ } else if (objPtr->typePtr == &tclIntType
+#ifndef NO_WIDE_TYPE
+ || objPtr->typePtr == &tclWideIntType
+#endif
+ ) {
if (Tcl_GetIntFromObj(NULL, objPtr, &level) != TCL_OK || level < 0) {
goto levelError;
}
@@ -683,6 +687,8 @@ TclObjGetFrame(interp, objPtr, framePtrPtr)
/*
* Cache for future reference.
+ *
+ * TODO: Use the new ptrAndLongRep intrep
*/
TclFreeIntRep(objPtr);
@@ -696,6 +702,8 @@ TclObjGetFrame(interp, objPtr, framePtrPtr)
/*
* Cache for future reference.
+ *
+ * TODO: Use the new ptrAndLongRep intrep
*/
TclFreeIntRep(objPtr);
diff --git a/generic/tclScan.c b/generic/tclScan.c
index 54f9b78..eede9f3 100644
--- a/generic/tclScan.c
+++ b/generic/tclScan.c
@@ -8,7 +8,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclScan.c,v 1.18 2005/07/21 14:38:51 dkf Exp $
+ * RCS: @(#) $Id: tclScan.c,v 1.19 2005/10/08 14:42:45 dgp Exp $
*/
#include "tclInt.h"
@@ -22,14 +22,17 @@
#define SCAN_UNSIGNED 0x4 /* Read an unsigned value. */
#define SCAN_WIDTH 0x8 /* A width value was supplied. */
+#if 0
#define SCAN_SIGNOK 0x10 /* A +/- character is allowed. */
#define SCAN_NODIGITS 0x20 /* No digits have been scanned. */
#define SCAN_NOZERO 0x40 /* No zero digits have been scanned. */
#define SCAN_XOK 0x80 /* An 'x' is allowed. */
#define SCAN_PTOK 0x100 /* Decimal point is allowed. */
#define SCAN_EXPOK 0x200 /* An exponent is allowed. */
+#endif
#define SCAN_LONGER 0x400 /* Asked for a wide value. */
+#define SCAN_BIG 0x800 /* Asked for a bignum value. */
/*
* The following structure contains the information associated with a
@@ -366,6 +369,12 @@ ValidateFormat(interp, format, numVars, totalSubs)
switch (ch) {
case 'l':
+ if (*format == 'l') {
+ flags |= SCAN_BIG;
+ format += 1;
+ format += Tcl_UtfToUniChar(format, &ch);
+ break;
+ }
case 'L':
flags |= SCAN_LONGER;
case 'h':
@@ -393,11 +402,11 @@ ValidateFormat(interp, format, numVars, totalSubs)
*/
case 'n':
case 's':
- if (flags & SCAN_LONGER) {
- invalidLonger:
+ if (flags & (SCAN_LONGER|SCAN_BIG)) {
+ invalidFieldSize:
buf[Tcl_UniCharToUtf(ch, buf)] = '\0';
Tcl_AppendResult(interp,
- "'l' modifier may not be specified in %", buf,
+ "field size modifier may not be specified in %", buf,
" conversion", NULL);
goto error;
}
@@ -410,15 +419,21 @@ ValidateFormat(interp, format, numVars, totalSubs)
case 'g':
case 'i':
case 'o':
- case 'u':
case 'x':
break;
+ case 'u':
+ if (flags & SCAN_BIG) {
+ Tcl_SetResult(interp,
+ "unsigned bignum scans are invalid", TCL_STATIC);
+ goto error;
+ }
+ break;
/*
* Bracket terms need special checking
*/
case '[':
- if (flags & SCAN_LONGER) {
- goto invalidLonger;
+ if (flags & (SCAN_LONGER|SCAN_BIG)) {
+ goto invalidFieldSize;
}
if (*format == '\0') {
goto badSet;
@@ -574,22 +589,24 @@ Tcl_ScanObjCmd(dummy, interp, objc, objv)
int numVars, nconversions, totalVars = -1;
int objIndex, offset, i, result, code;
long value;
- char *string, *end, *baseString;
+ CONST char *string, *end, *baseString;
char op = 0;
- int base = 0;
int underflow = 0;
size_t width;
- long (*fn) _ANSI_ARGS_((char*,void*,int)) = NULL;
-#ifndef TCL_WIDE_INT_IS_LONG
- Tcl_WideInt (*lfn) _ANSI_ARGS_((char*,void*,int)) = NULL;
Tcl_WideInt wideValue;
-#endif
Tcl_UniChar ch, sch;
Tcl_Obj **objs = NULL, *objPtr = NULL;
int flags;
char buf[513]; /* Temporary buffer to hold scanned number
* strings before they are passed to
* strtoul. */
+#if 0
+ int base = 0;
+ long (*fn) _ANSI_ARGS_((char*,void*,int)) = NULL;
+#ifndef TCL_WIDE_INT_IS_LONG
+ Tcl_WideInt (*lfn) _ANSI_ARGS_((char*,void*,int)) = NULL;
+#endif
+#endif
if (objc < 3) {
Tcl_WrongNumArgs(interp, 1, objv,
@@ -631,6 +648,7 @@ Tcl_ScanObjCmd(dummy, interp, objc, objv)
objIndex = 0;
nconversions = 0;
while (*format != '\0') {
+ int parseFlag = 0;
format += Tcl_UtfToUniChar(format, &ch);
flags = 0;
@@ -678,9 +696,10 @@ Tcl_ScanObjCmd(dummy, interp, objc, objv)
flags |= SCAN_SUPPRESS;
format += Tcl_UtfToUniChar(format, &ch);
} else if ((ch < 0x80) && isdigit(UCHAR(ch))) { /* INTL: "C" locale. */
- value = strtoul(format-1, &end, 10); /* INTL: "C" locale. */
- if (*end == '$') {
- format = end+1;
+ char *formatEnd;
+ value = strtoul(format-1, &formatEnd, 10);/* INTL: "C" locale. */
+ if (*formatEnd == '$') {
+ format = formatEnd+1;
format += Tcl_UtfToUniChar(format, &ch);
objIndex = (int) value - 1;
}
@@ -703,6 +722,12 @@ Tcl_ScanObjCmd(dummy, interp, objc, objv)
switch (ch) {
case 'l':
+ if (*format == 'l') {
+ flags |= SCAN_BIG;
+ format += 1;
+ format += Tcl_UtfToUniChar(format, &ch);
+ break;
+ }
case 'L':
flags |= SCAN_LONGER;
/*
@@ -728,44 +753,58 @@ Tcl_ScanObjCmd(dummy, interp, objc, objv)
case 'd':
op = 'i';
+ parseFlag = TCL_PARSE_DECIMAL_ONLY;
+#if 0
base = 10;
fn = (long (*) _ANSI_ARGS_((char*,void*,int)))strtol;
#ifndef TCL_WIDE_INT_IS_LONG
lfn = (Tcl_WideInt (*)_ANSI_ARGS_((char*,void*,int)))strtoll;
#endif
+#endif
break;
case 'i':
op = 'i';
+ parseFlag = TCL_PARSE_SCAN_PREFIXES;
+#if 0
base = 0;
fn = (long (*)_ANSI_ARGS_((char*,void*,int)))strtol;
#ifndef TCL_WIDE_INT_IS_LONG
lfn = (Tcl_WideInt (*)_ANSI_ARGS_((char*,void*,int)))strtoll;
#endif
+#endif
break;
case 'o':
op = 'i';
+ parseFlag = TCL_PARSE_OCTAL_ONLY | TCL_PARSE_SCAN_PREFIXES;
+#if 0
base = 8;
fn = (long (*)_ANSI_ARGS_((char*,void*,int)))strtoul;
#ifndef TCL_WIDE_INT_IS_LONG
lfn = (Tcl_WideInt (*)_ANSI_ARGS_((char*,void*,int)))strtoull;
#endif
+#endif
break;
case 'x':
op = 'i';
+ parseFlag = TCL_PARSE_HEXADECIMAL_ONLY;
+#if 0
base = 16;
fn = (long (*)_ANSI_ARGS_((char*,void*,int)))strtoul;
#ifndef TCL_WIDE_INT_IS_LONG
lfn = (Tcl_WideInt (*)_ANSI_ARGS_((char*,void*,int)))strtoull;
#endif
+#endif
break;
case 'u':
op = 'i';
- base = 10;
flags |= SCAN_UNSIGNED;
+#if 0
+ base = 10;
fn = (long (*)_ANSI_ARGS_((char*,void*,int)))strtoul;
#ifndef TCL_WIDE_INT_IS_LONG
lfn = (Tcl_WideInt (*)_ANSI_ARGS_((char*,void*,int)))strtoull;
#endif
+#endif
break;
case 'f':
@@ -903,6 +942,7 @@ Tcl_ScanObjCmd(dummy, interp, objc, objv)
* Scan an unsigned or signed integer.
*/
+#if 0
if ((width == 0) || (width > sizeof(buf) - 1)) {
width = sizeof(buf) - 1;
}
@@ -1049,111 +1089,91 @@ Tcl_ScanObjCmd(dummy, interp, objc, objv)
}
break;
-
- case 'f':
- /*
- * Scan a floating point number
- */
-
- if ((width == 0) || (width > sizeof(buf) - 1)) {
- width = sizeof(buf) - 1;
+#else
+ objPtr = Tcl_NewLongObj(0);
+ Tcl_IncrRefCount(objPtr);
+ if (width == 0) {
+ width = -1;
}
- flags &= ~SCAN_LONGER;
- flags |= SCAN_SIGNOK | SCAN_NODIGITS | SCAN_PTOK | SCAN_EXPOK;
- for (end = buf; width > 0; width--) {
- switch (*string) {
- case '0': case '1': case '2': case '3':
- case '4': case '5': case '6': case '7':
- case '8': case '9':
- flags &= ~(SCAN_SIGNOK | SCAN_NODIGITS);
- goto addToFloat;
- case '+': case '-':
- if (flags & SCAN_SIGNOK) {
- flags &= ~SCAN_SIGNOK;
- goto addToFloat;
- }
- break;
- case '.':
- if (flags & SCAN_PTOK) {
- flags &= ~(SCAN_SIGNOK | SCAN_PTOK);
- goto addToFloat;
- }
- break;
- case 'e': case 'E':
- /*
- * An exponent is not allowed until there has been at
- * least one digit.
- */
-
- if ((flags & (SCAN_NODIGITS | SCAN_EXPOK)) == SCAN_EXPOK) {
- flags = (flags & ~(SCAN_EXPOK|SCAN_PTOK))
- | SCAN_SIGNOK | SCAN_NODIGITS;
- goto addToFloat;
+ if (TclParseNumber(NULL, objPtr, NULL, string, width, &end,
+ TCL_PARSE_INTEGER_ONLY | parseFlag) != TCL_OK) {
+ Tcl_DecrRefCount(objPtr);
+ /* TODO: set underflow? test scan-4.44 */
+ goto done;
+ }
+ string = end;
+ if (flags & SCAN_SUPPRESS) {
+ Tcl_DecrRefCount(objPtr);
+ break;
+ }
+ if (flags & SCAN_LONGER) {
+ if (Tcl_GetWideIntFromObj(NULL, objPtr, &wideValue) != TCL_OK) {
+ wideValue = ~(Tcl_WideUInt)0 >> 1; /* WIDE_MAX */
+ if (Tcl_GetString(objPtr)[0] == '-') {
+ wideValue++; /* WIDE_MAX + 1 = WIDE_MIN */
}
- break;
}
-
- /*
- * We got an illegal character so we are done accumulating.
- */
-
- break;
-
- addToFloat:
- /*
- * Add the character to the temporary buffer.
- */
-
- *end++ = *string++;
- if (*string == '\0') {
- break;
+ if ((flags & SCAN_UNSIGNED) && (wideValue < 0)) {
+ sprintf(buf, "%" TCL_LL_MODIFIER "u",
+ (Tcl_WideUInt)wideValue);
+ Tcl_SetStringObj(objPtr, buf, -1);
+ } else {
+ Tcl_SetWideIntObj(objPtr, wideValue);
}
- }
-
- /*
- * Check to see if we need to back up because we saw a trailing
- * 'e' or sign.
- */
-
- if (flags & SCAN_NODIGITS) {
- if (flags & SCAN_EXPOK) {
- /*
- * There were no digits at all so scanning has failed and
- * we are done.
- */
-
- if (*string == '\0') {
- underflow = 1;
+ } else if (!(flags & SCAN_BIG)) {
+ if (Tcl_GetLongFromObj(NULL, objPtr, &value) != TCL_OK) {
+ if (Tcl_GetString(objPtr)[0] == '-') {
+ value = LONG_MIN;
+ } else {
+ value = LONG_MAX;
}
- goto done;
}
-
- /*
- * We got a bad exponent ('e' and maybe a sign).
- */
-
- end--;
- string--;
- if (*end != 'e' && *end != 'E') {
- end--;
- string--;
+ if ((flags & SCAN_UNSIGNED) && (value < 0)) {
+ sprintf(buf, "%lu", value); /* INTL: ISO digit */
+ Tcl_SetStringObj(objPtr, buf, -1);
+ } else {
+ Tcl_SetLongObj(objPtr, value);
}
}
+ objs[objIndex++] = objPtr;
+ break;
+#endif
+ case 'f':
/*
- * Scan the value from the temporary buffer.
+ * Scan a floating point number
*/
- if (!(flags & SCAN_SUPPRESS)) {
+ objPtr = Tcl_NewDoubleObj(0.0);
+ Tcl_IncrRefCount(objPtr);
+ if (width == 0) {
+ width = -1;
+ }
+ if (TclParseNumber(NULL, objPtr, NULL, string, width, &end,
+ TCL_PARSE_DECIMAL_ONLY) != TCL_OK) {
+ /* TODO: set underflow? test scan-4.55 */
+ Tcl_DecrRefCount(objPtr);
+ goto done;
+ } else if (flags & SCAN_SUPPRESS) {
+ Tcl_DecrRefCount(objPtr);
+ string = end;
+ } else {
double dvalue;
-
- *end = '\0';
- dvalue = TclStrToD(buf, NULL);
- objPtr = Tcl_NewDoubleObj(dvalue);
- Tcl_IncrRefCount(objPtr);
+ if (Tcl_GetDoubleFromObj(NULL, objPtr, &dvalue) != TCL_OK) {
+#ifdef ACCEPT_NAN
+ if (objPtr->typePtr == &tclDoubleType) {
+ dValue = objPtr->internalRep.doubleValue;
+ } else
+#endif
+ {
+ Tcl_DecrRefCount(objPtr);
+ goto done;
+ }
+ }
+ Tcl_SetDoubleObj(objPtr, dvalue);
objs[objIndex++] = objPtr;
+ string = end;
}
- break;
}
nconversions++;
}
diff --git a/generic/tclStrToD.c b/generic/tclStrToD.c
index 68f6c30..7f8ecd5 100755
--- a/generic/tclStrToD.c
+++ b/generic/tclStrToD.c
@@ -1,21 +1,20 @@
/*
*----------------------------------------------------------------------
*
- * tclStrToD.c --
+ * tclDouble.c --
*
- * This file contains a TclStrToD procedure that handles conversion of
- * string to double, with correct rounding even where extended precision
- * is needed to achieve that. It also contains a TclDoubleDigits
- * procedure that handles conversion of double to string (at least the
- * significand), and several utility functions for interconverting
- * 'double' and the integer types.
+ * This file contains a collection of procedures for managing
+ * conversions to/from floating-point in Tcl. They include
+ * TclParseNumber, which parses numbers from strings; TclDoubleDigits,
+ * which formats numbers into strings of digits, and procedures for
+ * interconversion among 'double' and 'mp_int' types.
*
* Copyright (c) 2005 by Kevin B. Kenny. All rights reserved.
*
* 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.8 2005/08/24 15:15:45 kennykb Exp $
+ * RCS: @(#) $Id: tclStrToD.c,v 1.9 2005/10/08 14:42:45 dgp Exp $
*
*----------------------------------------------------------------------
*/
@@ -30,34 +29,42 @@
#include <tommath.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.
+ * Define TIP_114_FORMATS to accept 0b and 0o for binary and octal strings.
+ * Define KILL_OCTAL as well as TIP_114_FORMATS to suppress interpretation
+ * of numbers with leading zero as octal. (Ceterum censeo: numeros octonarios
+ * delendos esse.)
*/
-#ifdef TCL_GENERIC_ONLY
-# define NO_ERRNO_H
-#endif
+#define TIP_114_FORMATS
+#undef KILL_OCTAL
-#ifdef NO_ERRNO_H
-extern int errno; /* Use errno from tclExecute.c. */
-# define ERANGE 34
+#ifndef TIP_114_FORMATS
+#undef KILL_OCTAL
#endif
+/*
+ * This code supports (at least hypothetically), IBM, Cray, VAX and
+ * IEEE-754 floating point; of these, only IEEE-754 can represent NaN.
+ * IEEE-754 can be uniquely determined by radix and by the widths of
+ * significand and exponent.
+ */
+
#if (FLT_RADIX == 2) && (DBL_MANT_DIG == 53) && (DBL_MAX_EXP == 1024)
# define IEEE_FLOATING_POINT
#endif
/*
- * gcc on x86 needs access to rounding controls. It is tempting to include
- * fpu_control.h, but that file exists only on Linux; it is missing on Cygwin
- * and MinGW. Most gcc-isms and ix86-isms are factored out here.
+ * gcc on x86 needs access to rounding controls, because of a questionable
+ * feature where it retains intermediate results as IEEE 'long double' values
+ * somewhat unpredictably. It is tempting to include fpu_control.h, but
+ * that file exists only on Linux; it is missing on Cygwin and MinGW. Most
+ * gcc-isms and ix86-isms are factored out here.
*/
#if defined(__GNUC__) && defined(__i386)
typedef unsigned int fpu_control_t __attribute__ ((__mode__ (__HI__)));
-# define _FPU_GETCW(cw) __asm__ ("fnstcw %0" : "=m" (*&cw))
-# define _FPU_SETCW(cw) __asm__ ("fldcw %0" : : "m" (*&cw))
+#define _FPU_GETCW(cw) __asm__ __volatile__ ("fnstcw %0" : "=m" (*&cw))
+#define _FPU_SETCW(cw) __asm__ __volatile__ ("fldcw %0" : : "m" (*&cw))
# define FPU_IEEE_ROUNDING 0x027f
# define ADJUST_FPU_CONTROL_WORD
#endif
@@ -75,13 +82,26 @@ typedef unsigned int fpu_control_t __attribute__ ((__mode__ (__HI__)));
# define NAN_MASK (((Tcl_WideUInt) 1) << 51)
#endif
-/*
- * There now follows a lot of static variables that are shared across all
- * threads but which are not guarded by mutexes. This is OK, because they are
- * only ever assigned _ONCE_ during Tcl's library initialization sequence.
- */
+/* The powers of ten that can be represented exactly as wide integers */
+
+static int maxpow10_wide;
+static Tcl_WideUInt *pow10_wide;
+
+/* The number of decimal digits that fit in an mp_digit */
+
+static int log10_DIGIT_MAX;
+
+/* The powers of ten that can be represented exactly as IEEE754 doubles. */
+
+#define MAXPOW 22
+static double pow10 [MAXPOW+1];
+
+static int mmaxpow; /* Largest power of ten that can be
+ * represented exactly in a 'double'. */
-static const double pow_10_2_n[] = { /* Inexact higher powers of ten */
+/* Inexact higher powers of ten */
+
+static CONST double pow_10_2_n [] = {
1.0,
100.0,
10000.0,
@@ -92,440 +112,1414 @@ static const double pow_10_2_n[] = { /* Inexact higher powers of ten */
1.0e+128,
1.0e+256
};
-#define MAXPOW 22 /* Num of exactly representable powers of 10 */
-static double pow10[MAXPOW+1]; /* The powers of ten that can be represented
- * exactly as IEEE754 doubles. */
-static int mmaxpow; /* Largest power of ten that can be
- * represented exactly in a 'double'. */
-static int log2FLT_RADIX; /* Logarithm of the floating point radix. */
-static int mantBits; /* Number of bits in a double's significand. */
-static mp_int pow5[9]; /* Table of powers of 5**(2**n), up to
- * 5**256. */
-static double tiny; /* The smallest representable double. */
-static int maxDigits; /* The maximum number of digits to the left of
- * the decimal point of a double. */
-static int minDigits; /* The maximum number of digits to the right
- * of the decimal point in a double. */
-static int mantDIGIT; /* Number of mp_digit's needed to hold the
- * significand of a double. */
+
+ /* Logarithm of the floating point radix. */
+
+static int log2FLT_RADIX;
+
+/* Number of bits in a double's significand */
+
+static int mantBits;
+
+/* Table of powers of 5**(2**n), up to 5**256 */
+
+static mp_int pow5[9];
+
+/* The smallest representable double */
+
+static double tiny;
+
+/* The maximum number of digits to the left of the decimal point of a
+ * double. */
+
+static int maxDigits;
+
+/* The maximum number of digits to the right of the decimal point in a
+ * double. */
+
+static int minDigits;
+
+/* Number of mp_digit's needed to hold the significand of a double */
+
+static int mantDIGIT;
/* Static functions defined in this file */
-static double RefineResult(double approx, CONST char *start, int nDigits,
- long exponent);
-static double ParseNaN(int signum, CONST char **end);
-static double SafeLdExp(double fraction, int exponent);
+static int AccumulateDecimalDigit _ANSI_ARGS_((unsigned, int,
+ Tcl_WideUInt*, mp_int*, int));
+static double MakeLowPrecisionDouble _ANSI_ARGS_((int signum,
+ Tcl_WideUInt significand,
+ int nSigDigs,
+ int exponent));
+static double MakeHighPrecisionDouble _ANSI_ARGS_((int signum,
+ mp_int* significand,
+ int nSigDigs,
+ int exponent));
+static double MakeNaN _ANSI_ARGS_(( int signum, Tcl_WideUInt tag ));
+static double RefineApproximation _ANSI_ARGS_((double approx,
+ mp_int* exactSignificand,
+ int exponent));
+static double AbsoluteValue(double v, int* signum);
+static int GetIntegerTimesPower(double v, mp_int* r, int* e);
+static double BignumToBiasedFrExp _ANSI_ARGS_(( mp_int* big, int* machexp ));
+static double Pow10TimesFrExp _ANSI_ARGS_(( int exponent,
+ double fraction,
+ int* machexp ));
+static double SafeLdExp _ANSI_ARGS_(( double fraction, int exponent ));
+
/*
*----------------------------------------------------------------------
*
- * TclStrToD --
+ * TclParseNumber --
*
- * Scans a double from a string.
+ * Place a "numeric" internal representation on a Tcl object.
*
* Results:
- * Returns the scanned number. In the case of underflow, returns an
- * appropriately signed zero; in the case of overflow, returns an
- * appropriately signed HUGE_VAL.
+ * Returns a standard Tcl result.
*
* Side effects:
- * Stores a pointer to the end of the scanned number in '*endPtr', if
- * endPtr is not NULL. If '*endPtr' is equal to 's' on return from this
- * function, it indicates that the input string could not be recognized
- * as a number. In the case of underflow or overflow, 'errno' is set to
- * ERANGE.
+ * Stores an internal representation appropriate to the string.
+ * The internal representation may be an integer, a wide integer,
+ * a bignum, or a double.
+ *
+ * TclMakeObjNumeric is called as a common scanner in routines
+ * that expect numbers in Tcl_Obj's. It scans the string representation
+ * of a given Tcl_Obj and stores an internal rep that represents
+ * a "canonical" version of its numeric value. The value of the
+ * canonicalization is that a routine can determine simply by
+ * examining the type pointer whether an object LooksLikeInt,
+ * what size of integer is needed to hold it, and similar questions,
+ * and never needs to refer back to the string representation, even
+ * for "impure" objects.
+ *
+ * The 'strPtr' and 'endPtrPtr' arguments allow for recognizing a number
+ * that is in a substring of a Tcl_Obj, for example a screen metric or
+ * "end-" index. If 'strPtr' is not NULL, it designates where the
+ * number begins within the string. (The default is the start of
+ * objPtr's string rep, which will be constructed if necessary.)
*
- *------------------------------------------------------------------------
+ * If 'strPtr' is supplied, 'objPtr' may be NULL. In this case,
+ * no internal representation will be generated; instead, the routine
+ * will simply check for a syntactically correct number, returning
+ * TCL_OK or TCL_ERROR as appropriate, and setting *endPtrPtr if
+ * necessary.
+ *
+ * If 'endPtrPtr' is not NULL, it designates the first character
+ * after the scanned number. In this case, successfully recognizing
+ * any digits will yield a return code of TCL_OK. Only in the case
+ * where no leading string of 'strPtr' (or of objPtr's internal rep)
+ * represents a number will TCL_ERROR be returned.
+ *
+ * When only a partial string is being recognized, it is the caller's
+ * responsibility to destroy the internal representation, or at
+ * least change its type. Failure to do so will lead to subsequent
+ * problems where a string that does not represent a number will
+ * be recognized as one because it has a numeric internal representation.
+ *
+ * When the 'flags' word includes TCL_PARSE_DECIMAL_ONLY, only decimal
+ * numbers are recognized; leading 0 has no special interpretation as
+ * octal and leading '0x' is forbidden.
+ *
+ *----------------------------------------------------------------------
*/
-double
-TclStrToD(CONST char *s, /* String to scan. */
- CONST char **endPtr) /* Pointer to the end of the scanned number. */
+int
+TclParseNumber( Tcl_Interp* interp,
+ /* Tcl interpreter for error reporting.
+ * May be NULL */
+ Tcl_Obj* objPtr,
+ /* Object to receive the internal rep */
+ CONST char* type,
+ /* Type of number being parsed ("integer",
+ * "wide integer", etc. */
+ CONST char* string,
+ /* Pointer to the start of the string to
+ * scan, see above */
+ size_t length, /* Maximum length of the string to scan,
+ * see above. */
+ CONST char** endPtrPtr,
+ /* (Output) pointer to the end of the
+ * scanned number, see above */
+ int flags) /* Flags governing the parse */
{
- const char *p = s;
- const char *startOfSignificand = NULL;
- /* Start of the significand in the string. */
- int signum = 0; /* Sign of the significand. */
- double exactSignificand = 0.0;
- /* Significand, represented exactly as a
- * floating-point number. */
- int seenDigit = 0; /* Flag == 1 if a digit has been seen. */
- int nSigDigs = 0; /* Number of significant digits presented. */
- int nDigitsAfterDp = 0; /* Number of digits after the decimal point. */
- int nTrailZero = 0; /* Number of trailing zeros in the
- * significand. */
- long exponent = 0; /* Exponent. */
- int seenDp = 0; /* Flag == 1 if decimal point has been seen. */
- char c; /* One character extracted from the input. */
- volatile double v; /* Scanned value; must be 'volatile double' on
- * gc-ix86 to force correct rounding to IEEE
- * double and not Intel double-extended. */
- int machexp; /* Exponent of the machine rep of the scanned
- * value. */
- int expt2; /* Exponent for computing first approximation
- * to the true value. */
- int i, j;
- /*
- * With gcc on x86, the floating point rounding mode is double-extended.
- * This causes the result of double-precision calculations to be rounded
- * twice: once to the precision of double-extended and then again to the
- * precision of double. Double-rounding introduces gratuitous errors of
- * one ulp, so we need to change rounding mode to 53-bits.
- */
-
-#ifdef ADJUST_FPU_CONTROL_WORD
- fpu_control_t roundTo53Bits = FPU_IEEE_ROUNDING;
- fpu_control_t oldRoundingMode;
- _FPU_GETCW(oldRoundingMode);
- _FPU_SETCW(roundTo53Bits);
-# define RestoreRoundingMode() _FPU_SETCW(oldRoundingMode)
-#else
-# define RestoreRoundingMode() (void) 0 /* Do nothing */
+ enum State {
+ INITIAL, SIGNUM, ZERO, ZERO_X,
+#ifdef TIP_114_FORMATS
+ ZERO_O, ZERO_B, BINARY,
+#endif
+ HEXADECIMAL, OCTAL, BAD_OCTAL, DECIMAL,
+ LEADING_RADIX_POINT, FRACTION,
+ EXPONENT_START, EXPONENT_SIGNUM, EXPONENT,
+ sI, sIN, sINF, sINFI, sINFIN, sINFINI, sINFINIT, sINFINITY
+#ifdef IEEE_FLOATING_POINT
+ , sN, sNA, sNAN, sNANPAREN, sNANHEX, sNANFINISH
+#endif
+ } state = INITIAL;
+ enum State acceptState = INITIAL;
+
+ int signum = 0; /* Sign of the number being parsed */
+ Tcl_WideUInt significandWide = 0;
+ /* Significand of the number being
+ * parsed (if no overflow) */
+ mp_int significandBig; /* Significand of the number being
+ * parsed (if it overflows significandWide) */
+ int significandOverflow = 0;
+ /* Flag==1 iff significandBig is used */
+ Tcl_WideUInt octalSignificandWide = 0;
+ /* Significand of an octal number; needed
+ * because we don't know whether a number
+ * with a leading zero is octal or decimal
+ * until we've scanned forward to a '.' or
+ * 'e' */
+ mp_int octalSignificandBig; /* Significand of octal number once
+ * octalSignificandWide overflows */
+ int octalSignificandOverflow = 0;
+ /* Flag==1 if octalSignificandBig is used */
+ int numSigDigs = 0; /* Number of significant digits in the
+ * decimal significand */
+ int numTrailZeros = 0; /* Number of trailing zeroes at the
+ * current point in the parse. */
+ int numDigitsAfterDp = 0; /* Number of digits scanned after the
+ * decimal point */
+ int exponentSignum = 0; /* Signum of the exponent of a floating
+ * point number */
+ long exponent = 0; /* Exponent of a floating point number */
+ CONST char* p; /* Pointer to next character to scan */
+ size_t len; /* Number of characters remaining after p */
+ CONST char* acceptPoint; /* Pointer to position after last character
+ * in an acceptable number */
+ size_t acceptLen; /* Number of characters following that point */
+ int status = TCL_OK; /* Status to return to caller */
+ char d; /* Last hexadecimal digit scanned */
+ int shift = 0; /* Amount to shift when accumulating binary */
+#ifdef TIP_114_FORMATS
+ int explicitOctal = 0;
#endif
- /*
- * Discard leading whitespace from input.
+ /*
+ * Initialize string to start of the object's string rep if
+ * the caller didn't pass anything else.
*/
- while (isspace(UCHAR(*p))) {
- ++p;
+ if ( string == NULL ) {
+ string = Tcl_GetStringFromObj( objPtr, NULL );
}
- /*
- * Determine the sign of the significand.
- */
+ p = string;
+ len = length;
+ acceptPoint = p;
+ acceptLen = len;
+ while ( 1 ) {
+ char c = len ? *p : '\0';
+ switch (state) {
- switch (*p) {
- case '-':
- signum = 1;
+ case INITIAL:
+ /*
+ * Initial state. Acceptable characters are +, -, digits,
+ * period, I, N, and whitespace.
+ */
+ if (isspace(UCHAR(c))) {
+ break;
+ } else if (c == '+') {
+ state = SIGNUM;
+ break;
+ } else if (c == '-') {
+ signum = 1;
+ state = SIGNUM;
+ break;
+ }
/* FALLTHROUGH */
- case '+':
- ++p;
- }
-
- /*
- * Discard leading zeroes from input.
- */
+
+ case SIGNUM:
+ /*
+ * Scanned a leading + or -. Acceptable characters are
+ * digits, period, I, and N.
+ */
+ if (c == '0') {
+ if (flags & TCL_PARSE_DECIMAL_ONLY) {
+ state = DECIMAL;
+ } else {
+ state = ZERO;
+ }
+ break;
+ } else if (flags & TCL_PARSE_HEXADECIMAL_ONLY) {
+ goto zerox;
+ } else if (flags & TCL_PARSE_OCTAL_ONLY) {
+ goto zeroo;
+ } else if (isdigit(UCHAR(c))) {
+ significandWide = c - '0';
+ numSigDigs = 1;
+ state = DECIMAL;
+ break;
+ } else if (flags & TCL_PARSE_INTEGER_ONLY) {
+ goto endgame;
+ } else if (c == '.') {
+ state = LEADING_RADIX_POINT;
+ break;
+ } else if (c == 'I' || c == 'i') {
+ state = sI;
+ break;
+#ifdef IEEE_FLOATING_POINT
+ } else if (c == 'N' || c == 'n') {
+ state = sN;
+ break;
+#endif
+ }
+ goto endgame;
- while (*p == '0') {
- seenDigit = 1;
- ++p;
- }
+ case ZERO:
+ /*
+ * Scanned a leading zero (perhaps with a + or -).
+ * Acceptable inputs are digits, period, X, and E.
+ * If 8 or 9 is encountered, the number can't be
+ * octal. This state and the OCTAL state differ only
+ * in whether they recognize 'X'.
+ */
+ acceptState = state;
+ acceptPoint = p;
+ acceptLen = len;
+ if (c == 'x' || c == 'X') {
+ state = ZERO_X;
+ break;
+ }
+ if (flags & TCL_PARSE_HEXADECIMAL_ONLY) {
+ goto zerox;
+ }
+#ifdef TIP_114_FORMATS
+ if (flags & TCL_PARSE_SCAN_PREFIXES) {
+ goto zeroo;
+ }
+ if (c == 'b' || c == 'B') {
+ state = ZERO_B;
+ break;
+ }
+ if (c == 'o' || c == 'O') {
+ explicitOctal = 1;
+ state = ZERO_O;
+ break;
+ }
+#ifdef KILL_OCTAL
+ goto decimal;
+#endif
+#endif
+ /* FALLTHROUGH */
- /*
- * Scan digits from the significand. Simultaneously, keep track of the
- * number of digits after the decimal point. Maintain a pointer to the
- * start of the significand. Keep "exactSignificand" equal to the
- * conversion of the DBL_DIG most significant digits.
- */
+ case OCTAL:
+ /*
+ * Scanned an optional + or -, followed by a string of
+ * octal digits. Acceptable inputs are more digits,
+ * period, or E. If 8 or 9 is encountered, commit to
+ * floating point.
+ */
+ acceptState = state;
+ acceptPoint = p;
+ acceptLen = len;
+#ifdef TIP_114_FORMATS
+ /* FALLTHROUGH */
+ case ZERO_O:
+#endif
+ zeroo:
+ if (c == '0') {
+ ++numTrailZeros;
+ state = OCTAL;
+ break;
+ } else if (c >= '1' && c <= '7') {
+ if (objPtr != NULL) {
+ shift = 3 * (numTrailZeros + 1);
+ significandOverflow =
+ AccumulateDecimalDigit((unsigned)(c-'0'),
+ numTrailZeros,
+ &significandWide,
+ &significandBig,
+ significandOverflow);
+
+ if (!octalSignificandOverflow) {
+ /*
+ * Shifting by more bits than are in the value being
+ * shifted is at least de facto nonportable. Check
+ * for too large shifts first.
+ */
+ if ((octalSignificandWide != 0)
+ && ((shift >= CHAR_BIT*sizeof(Tcl_WideUInt))
+ || (octalSignificandWide
+ > (~(Tcl_WideUInt)0 >> shift)))) {
+ octalSignificandOverflow = 1;
+ TclBNInitBignumFromWideUInt(&octalSignificandBig,
+ octalSignificandWide);
+ }
+ }
+ if (!octalSignificandOverflow) {
+ octalSignificandWide
+ = (octalSignificandWide << shift) + (c - '0');
+ } else {
+ mp_mul_2d(&octalSignificandBig, shift,
+ &octalSignificandBig);
+ mp_add_d(&octalSignificandBig, (mp_digit)(c - '0'),
+ &octalSignificandBig);
+ }
+ }
+ if ( numSigDigs != 0 ) {
+ numSigDigs += ( numTrailZeros + 1 );
+ } else {
+ numSigDigs = 1;
+ }
+ numTrailZeros = 0;
+ state = OCTAL;
+ break;
+ }
+ /* FALLTHROUGH */
- for (;;) {
- c = *p;
- if (c == '.' && !seenDp) {
- seenDp = 1;
- ++p;
- } else if (isdigit(UCHAR(c))) {
+ case BAD_OCTAL:
+#ifdef TIP_114_FORMATS
+ if (explicitOctal) {
+ /* No forgiveness for bad digits in explicitly octal numbers */
+ goto endgame;
+ }
+#endif
+ if (flags & TCL_PARSE_INTEGER_ONLY) {
+ /* No seeking floating point when parsing only integer */
+ goto endgame;
+ }
+#ifndef KILL_OCTAL
+ /*
+ * Scanned a number with a leading zero that contains an
+ * 8, 9, radix point or E. This is an invalid octal number,
+ * but might still be floating point.
+ */
if (c == '0') {
- if (startOfSignificand != NULL) {
- ++nTrailZero;
+ ++numTrailZeros;
+ state = BAD_OCTAL;
+ break;
+ } else if (isdigit(UCHAR(c))) {
+ if (objPtr != NULL) {
+ significandOverflow =
+ AccumulateDecimalDigit((unsigned)(c-'0'),
+ numTrailZeros,
+ &significandWide,
+ &significandBig,
+ significandOverflow);
+ }
+ if ( numSigDigs != 0 ) {
+ numSigDigs += ( numTrailZeros + 1 );
+ } else {
+ numSigDigs = 1;
}
+ numTrailZeros = 0;
+ state = BAD_OCTAL;
+ break;
+ } else if (c == '.') {
+ state = FRACTION;
+ break;
+ } else if (c == 'E' || c == 'e') {
+ state = EXPONENT_START;
+ break;
+ }
+#endif
+ goto endgame;
+
+ /*
+ * Scanned 0x. If state is HEXADECIMAL, scanned at least
+ * one character following the 0x. The only acceptable
+ * inputs are hexadecimal digits.
+ */
+ case HEXADECIMAL:
+ acceptState = state;
+ acceptPoint = p;
+ acceptLen = len;
+ /* FALLTHROUGH */
+ case ZERO_X:
+ zerox:
+ if (c == '0') {
+ ++numTrailZeros;
+ state = HEXADECIMAL;
+ break;
+ } else if (isdigit(UCHAR(c))) {
+ d = (c-'0');
+ } else if (c >= 'A' && c <= 'F') {
+ d = (c-'A'+10);
+ } else if (c >= 'a' && c <= 'f') {
+ d = (c-'a'+10);
} else {
- if (startOfSignificand == NULL) {
- startOfSignificand = p;
- } else if (nTrailZero) {
- if (nTrailZero + nSigDigs < DBL_DIG) {
- exactSignificand *= pow10[nTrailZero];
- } else if (nSigDigs < DBL_DIG) {
- exactSignificand *= pow10[DBL_DIG - nSigDigs];
+ goto endgame;
+ }
+ if (objPtr != NULL) {
+ shift = 4 * (numTrailZeros + 1);
+ if (!significandOverflow) {
+ /*
+ * Shifting by more bits than are in the value being
+ * shifted is at least de facto nonportable. Check
+ * for too large shifts first.
+ */
+ if (significandWide != 0
+ && (shift >= CHAR_BIT*sizeof(Tcl_WideUInt)
+ || significandWide > (~(Tcl_WideUInt)0 >> shift))) {
+ significandOverflow = 1;
+ TclBNInitBignumFromWideUInt(&significandBig,
+ significandWide);
}
- nSigDigs += nTrailZero;
}
- if (nSigDigs < DBL_DIG) {
- exactSignificand = 10. * exactSignificand + (c - '0');
+ if (!significandOverflow) {
+ significandWide
+ = (significandWide << shift) + d;
+ } else {
+ mp_mul_2d(&significandBig, shift,
+ &significandBig);
+ mp_add_d(&significandBig, (mp_digit) d,
+ &significandBig);
}
- ++nSigDigs;
- nTrailZero = 0;
}
- if (seenDp) {
- ++nDigitsAfterDp;
+ numTrailZeros = 0;
+ state = HEXADECIMAL;
+ break;
+
+#ifdef TIP_114_FORMATS
+ case BINARY:
+ acceptState = state;
+ acceptPoint = p;
+ acceptLen = len;
+ case ZERO_B:
+ if (c == '0') {
+ ++numTrailZeros;
+ state = BINARY;
+ break;
+ } else if (c != '1') {
+ goto endgame;
}
- seenDigit = 1;
- ++p;
- } else {
+ if (objPtr != NULL) {
+ shift = numTrailZeros + 1;
+ if (!significandOverflow) {
+ /*
+ * Shifting by more bits than are in the value being
+ * shifted is at least de facto nonportable. Check
+ * for too large shifts first.
+ */
+ if (significandWide != 0
+ && (shift >= CHAR_BIT*sizeof(Tcl_WideUInt)
+ || significandWide > (~(Tcl_WideUInt)0 >> shift))) {
+ significandOverflow = 1;
+ TclBNInitBignumFromWideUInt(&significandBig,
+ significandWide);
+ }
+ }
+ if (!significandOverflow) {
+ significandWide
+ = (significandWide << shift) + 1;
+ } else {
+ mp_mul_2d(&significandBig, shift,
+ &significandBig);
+ mp_add_d(&significandBig, (mp_digit) 1,
+ &significandBig);
+ }
+ }
+ numTrailZeros = 0;
+ state = BINARY;
break;
- }
- }
+#endif
- /*
- * At this point, we've scanned the significand, and p points to the
- * character beyond it. "startOfSignificand" is the first non-zero
- * character in the significand. "nSigDigs" is the number of significant
- * digits of the significand, not including any trailing zeroes.
- * "exactSignificand" is a floating point number that represents, without
- * loss of precision, the first min(DBL_DIG,n) digits of the significand.
- * "nDigitsAfterDp" is the number of digits after the decimal point, again
- * excluding trailing zeroes.
- *
- * Now scan 'E' format
- */
+ case DECIMAL:
+ /*
+ * Scanned an optional + or - followed by a string of
+ * decimal digits.
+ */
+#ifdef KILL_OCTAL
+ decimal:
+#endif
+ acceptState = state;
+ acceptPoint = p;
+ acceptLen = len;
+ if (c == '0') {
+ ++numTrailZeros;
+ state = DECIMAL;
+ break;
+ } else if (isdigit(UCHAR(c))) {
+ if (objPtr != NULL) {
+ significandOverflow =
+ AccumulateDecimalDigit((unsigned)(c - '0'),
+ numTrailZeros,
+ &significandWide,
+ &significandBig,
+ significandOverflow);
+ }
+ numSigDigs += ( numTrailZeros + 1 );
+ numTrailZeros = 0;
+ state = DECIMAL;
+ break;
+ } else if (flags & TCL_PARSE_INTEGER_ONLY) {
+ goto endgame;
+ } else if (c == '.') {
+ state = FRACTION;
+ break;
+ } else if (c == 'E' || c == 'e') {
+ state = EXPONENT_START;
+ break;
+ }
+ goto endgame;
- exponent = 0;
- if (seenDigit && (*p == 'e' || *p == 'E')) {
- const char* stringSave = p;
- ++p;
- c = *p;
- if (isdigit(UCHAR(c)) || c == '+' || c == '-') {
- errno = 0;
- exponent = strtol(p, (char**)&p, 10);
- if (errno == ERANGE) {
- if (exponent > 0) {
- v = HUGE_VAL;
+ /*
+ * Found a decimal point. If no digits have yet been scanned,
+ * E is not allowed; otherwise, it introduces the exponent.
+ * If at least one digit has been found, we have a possible
+ * complete number.
+ */
+ case FRACTION:
+ acceptState = state;
+ acceptPoint = p;
+ acceptLen = len;
+ if (c == 'E' || c=='e') {
+ state = EXPONENT_START;
+ break;
+ }
+ /* FALLTHROUGH */
+ case LEADING_RADIX_POINT:
+ if (c == '0') {
+ ++numDigitsAfterDp;
+ ++numTrailZeros;
+ state = FRACTION;
+ break;
+ } else if (isdigit(UCHAR(c))) {
+ ++numDigitsAfterDp;
+ if (objPtr != NULL) {
+ significandOverflow =
+ AccumulateDecimalDigit((unsigned)(c-'0'),
+ numTrailZeros,
+ &significandWide,
+ &significandBig,
+ significandOverflow);
+ }
+ if ( numSigDigs != 0 ) {
+ numSigDigs += ( numTrailZeros + 1 );
} else {
- v = 0.0;
+ numSigDigs = 1;
}
- *endPtr = p;
- goto returnValue;
+ numTrailZeros = 0;
+ state = FRACTION;
+ break;
}
- }
- if (p == stringSave+1) {
- p = stringSave;
- exponent = 0;
- }
- }
- exponent += nTrailZero - nDigitsAfterDp;
+ goto endgame;
- /*
- * If we come here with no significant digits, we might still be looking
- * at Inf or NaN. Go parse them.
- */
+ case EXPONENT_START:
+ /*
+ * Scanned the E at the start of an exponent. Make sure
+ * a legal character follows before using the C library
+ * strtol routine, which allows whitespace.
+ */
+ if (c == '+') {
+ state = EXPONENT_SIGNUM;
+ break;
+ } else if (c == '-') {
+ exponentSignum = 1;
+ state = EXPONENT_SIGNUM;
+ break;
+ }
+ /* FALLTHROUGH */
- if (!seenDigit) {
- /*
- * Test for Inf or Infinity (in any case).
- */
+ case EXPONENT_SIGNUM:
+ /*
+ * Found the E at the start of the exponent, followed by
+ * a sign character.
+ */
+ if (isdigit(UCHAR(c))) {
+ exponent = c - '0';
+ state = EXPONENT;
+ break;
+ }
+ goto endgame;
- if (c == 'I' || c == 'i') {
- if ((p[1] == 'N' || p[1] == 'n')
- && (p[2] == 'F' || p[2] == 'f')) {
- p += 3;
- if ((p[0] == 'I' || p[0] == 'i')
- && (p[1] == 'N' || p[1] == 'n')
- && (p[2] == 'I' || p[2] == 'i')
- && (p[3] == 'T' || p[3] == 't')
- && (p[4] == 'Y' || p[1] == 'y')) {
- p += 5;
- }
- errno = ERANGE;
- v = HUGE_VAL;
- if (endPtr != NULL) {
- *endPtr = p;
+ case EXPONENT:
+ /*
+ * Found an exponent with at least one digit.
+ * Accumulate it, making sure to hard-pin it to LONG_MAX
+ * on overflow.
+ */
+ acceptState = state;
+ acceptPoint = p;
+ acceptLen = len;
+ if (isdigit(UCHAR(c))) {
+ if (exponent < (LONG_MAX - 9) / 10) {
+ exponent = 10 * exponent + (c - '0');
+ } else {
+ exponent = LONG_MAX;
}
- goto returnValue;
+ state = EXPONENT;
+ break;
}
+ goto endgame;
-#ifdef IEEE_FLOATING_POINT
/*
- * Only IEEE floating point supports NaN
+ * Parse out INFINITY by simply spelling it out.
+ * INF is accepted as an abbreviation; other prefices are
+ * not.
*/
- } else if ((c == 'N' || c == 'n')
- && (sizeof(Tcl_WideUInt) == sizeof(double))) {
- if ((p[1] == 'A' || p[1] == 'a')
- && (p[2] == 'N' || p[2] == 'n')) {
- p += 3;
-
- if (endPtr != NULL) {
- *endPtr = p;
- }
+ case sI:
+ if ( c == 'n' || c == 'N' ) {
+ state = sIN;
+ break;
+ }
+ goto endgame;
+ case sIN:
+ if ( c == 'f' || c == 'F' ) {
+ state = sINF;
+ break;
+ }
+ goto endgame;
+ case sINF:
+ acceptState = state;
+ acceptPoint = p;
+ acceptLen = len;
+ if ( c == 'i' || c == 'I' ) {
+ state = sINFI;
+ break;
+ }
+ goto endgame;
+ case sINFI:
+ if ( c == 'n' || c == 'N' ) {
+ state = sINFIN;
+ break;
+ }
+ goto endgame;
+ case sINFIN:
+ if ( c == 'i' || c == 'I' ) {
+ state = sINFINI;
+ break;
+ }
+ goto endgame;
+ case sINFINI:
+ if ( c == 't' || c == 'T' ) {
+ state = sINFINIT;
+ break;
+ }
+ goto endgame;
+ case sINFINIT:
+ if ( c == 'y' || c == 'Y' ) {
+ state = sINFINITY;
+ break;
+ }
+ goto endgame;
- /*
- * Restore FPU mode word.
- */
+ /*
+ * Parse NaN's.
+ */
+#ifdef IEEE_FLOATING_POINT
+ case sN:
+ if ( c == 'a' || c == 'A' ) {
+ state = sNA;
+ break;
+ }
+ goto endgame;
+ case sNA:
+ if ( c == 'n' || c == 'N' ) {
+ state = sNAN;
+ break;
+ }
+ case sNAN:
+ acceptState = state;
+ acceptPoint = p;
+ acceptLen = len;
+ if ( c == '(' ) {
+ state = sNANPAREN;
+ break;
+ }
+ goto endgame;
- RestoreRoundingMode();
- return ParseNaN(signum, endPtr);
+ /*
+ * Parse NaN(hexdigits)
+ */
+ case sNANHEX:
+ if ( c == ')' ) {
+ state = sNANFINISH;
+ break;
}
+ /* FALLTHROUGH */
+ case sNANPAREN:
+ if ( isspace(UCHAR(c)) ) {
+ break;
+ }
+ if ( numSigDigs < 13 ) {
+ if ( c >= '0' && c <= '9' ) {
+ d = c - '0';
+ } else if ( c >= 'a' && c <= 'f' ) {
+ d = 10 + c - 'a';
+ } else if ( c >= 'A' && c <= 'F' ) {
+ d = 10 + c - 'A';
+ }
+ significandWide = (significandWide << 4) + d;
+ state = sNANHEX;
+ break;
+ }
+ goto endgame;
+ case sNANFINISH:
#endif
+ case sINFINITY:
+ acceptState = state;
+ acceptPoint = p;
+ acceptLen = len;
+ goto endgame;
}
+ ++p;
+ --len;
+ }
+
+ endgame:
- goto error;
+ /* Back up to the last accepting state in the lexer */
+
+ if (acceptState == INITIAL) {
+ status = TCL_ERROR;
}
+ p = acceptPoint;
+ len = acceptLen;
- /*
- * We've successfully scanned; update the end-of-element pointer.
- */
+ /* Skip past trailing whitespace */
- if (endPtr != NULL) {
- *endPtr = p;
+ if (endPtrPtr != NULL) {
+ *endPtrPtr = p;
}
- /*
- * Test for zero.
- */
+ while (len > 0 && isspace(UCHAR(*p))) {
+ ++p;
+ --len;
+ }
- if (nSigDigs == 0) {
- v = 0.0;
- goto returnValue;
+ /* Determine whether a partial string is acceptable. */
+
+ if (endPtrPtr == NULL && len != 0 && *p != '\0') {
+ status = TCL_ERROR;
}
- /*
- * The easy cases are where we have an exact significand and the exponent
- * is small enough that we can compute the value with only one roundoff.
- * In addition to the cases where we can multiply or divide an
- * exact-integer significand by an exact-integer power of 10, there is
- * also David Gay's case where we can scale the significand by a power of
- * 10 (still keeping it exact) and then multiply by an exact power of 10.
- * The last case enables combinations like 83e25 that would otherwise
- * require high precision arithmetic.
- */
+ /* Generate and store the appropriate internal rep */
- if (nSigDigs <= DBL_DIG) {
- if (exponent >= 0) {
- if (exponent <= mmaxpow) {
- v = exactSignificand * pow10[exponent];
- goto returnValue;
- } else {
- int diff = DBL_DIG - nSigDigs;
- if (exponent - diff <= mmaxpow) {
- volatile double factor = exactSignificand * pow10[diff];
- v = factor * pow10[exponent - diff];
- goto returnValue;
+ if (status == TCL_OK && objPtr != NULL) {
+ if ( acceptState != INITIAL ) {
+ TclFreeIntRep( objPtr );
+ }
+ switch (acceptState) {
+
+ case INITIAL:
+ status = TCL_ERROR;
+ break;
+
+ case SIGNUM:
+ case BAD_OCTAL:
+ case ZERO_X:
+#ifdef TIP_114_FORMATS
+ case ZERO_O:
+ case ZERO_B:
+#endif
+ case LEADING_RADIX_POINT:
+ case EXPONENT_START:
+ case EXPONENT_SIGNUM:
+ case sI:
+ case sIN:
+ case sINFI:
+ case sINFIN:
+ case sINFINI:
+ case sINFINIT:
+ case sN:
+ case sNA:
+ case sNANPAREN:
+ case sNANHEX:
+ panic("in TclParseNumber: bad acceptState, can't happen.");
+
+#ifdef TIP_114_FORMATS
+ case BINARY:
+ shift = numTrailZeros;
+ if (!significandOverflow) {
+ if (significandWide !=0
+ && (shift >= CHAR_BIT*sizeof(Tcl_WideUInt)
+ || significandWide
+ > (((~(Tcl_WideUInt)0) >> 1) + signum) >> shift )) {
+ significandOverflow = 1;
+ TclBNInitBignumFromWideUInt(&significandBig,
+ significandWide);
}
}
- } else if (exponent >= -mmaxpow) {
- v = exactSignificand / pow10[-exponent];
- goto returnValue;
+ if (shift) {
+ if ( !significandOverflow ) {
+ significandWide <<= shift;
+ } else {
+ mp_mul_2d( &significandBig, shift, &significandBig );
+ }
+ }
+ goto returnInteger;
+#endif
+ case HEXADECIMAL:
+ /* Returning a hex integer. Final scaling step */
+ shift = 4 * numTrailZeros;
+ if (!significandOverflow) {
+ if (significandWide !=0
+ && (shift >= CHAR_BIT*sizeof(Tcl_WideUInt)
+ || significandWide
+ > (((~(Tcl_WideUInt)0) >> 1) + signum) >> shift )) {
+ significandOverflow = 1;
+ TclBNInitBignumFromWideUInt(&significandBig,
+ significandWide);
+ }
+ }
+ if (shift) {
+ if ( !significandOverflow ) {
+ significandWide <<= shift;
+ } else {
+ mp_mul_2d( &significandBig, shift, &significandBig );
+ }
+ }
+ goto returnInteger;
+
+ case OCTAL:
+ /* Returning an octal integer. Final scaling step */
+ shift = 3 * numTrailZeros;
+ if (!octalSignificandOverflow) {
+ if (octalSignificandWide != 0
+ && (shift >= CHAR_BIT*sizeof(Tcl_WideUInt)
+ || octalSignificandWide
+ > (((~(Tcl_WideUInt)0) >> 1) + signum) >> shift )) {
+ octalSignificandOverflow = 1;
+ TclBNInitBignumFromWideUInt(&octalSignificandBig,
+ octalSignificandWide);
+ }
+ }
+ if ( shift ) {
+ if ( !octalSignificandOverflow ) {
+ octalSignificandWide <<= shift;
+ } else {
+ mp_mul_2d( &octalSignificandBig, shift,
+ &octalSignificandBig );
+ }
+ }
+ if (!octalSignificandOverflow) {
+ if (octalSignificandWide >
+ (Tcl_WideUInt)(((~(unsigned long)0) >> 1) + signum)) {
+#ifndef NO_WIDE_TYPE
+ if (octalSignificandWide
+ <= (((~(Tcl_WideUInt)0) >> 1) + signum)) {
+ objPtr->typePtr = &tclWideIntType;
+ if (signum) {
+ objPtr->internalRep.wideValue =
+ - (Tcl_WideInt) octalSignificandWide;
+ } else {
+ objPtr->internalRep.wideValue =
+ (Tcl_WideInt) octalSignificandWide;
+ }
+ break;
+ }
+#endif
+ TclBNInitBignumFromWideUInt(&octalSignificandBig,
+ octalSignificandWide);
+ octalSignificandOverflow = 1;
+ } else {
+ objPtr->typePtr = &tclIntType;
+ if (signum) {
+ objPtr->internalRep.longValue =
+ - (long) octalSignificandWide;
+ } else {
+ objPtr->internalRep.longValue =
+ (long) octalSignificandWide;
+ }
+ }
+ }
+ if (octalSignificandOverflow) {
+ if (signum) {
+ mp_neg(&octalSignificandBig, &octalSignificandBig);
+ }
+ TclSetBignumIntRep(objPtr, &octalSignificandBig);
+ }
+ break;
+
+ case ZERO:
+ case DECIMAL:
+ significandOverflow =
+ AccumulateDecimalDigit( 0, numTrailZeros-1,
+ &significandWide, &significandBig,
+ significandOverflow );
+ if (!significandOverflow
+ && (significandWide
+ > (((~(Tcl_WideUInt)0) >> 1) + signum))) {
+ significandOverflow = 1;
+ TclBNInitBignumFromWideUInt(&significandBig,
+ significandWide);
+ }
+ returnInteger:
+ if (!significandOverflow) {
+ if (significandWide >
+ (Tcl_WideUInt)(((~(unsigned long)0) >> 1) + signum)) {
+#ifndef NO_WIDE_TYPE
+ if (significandWide
+ <= (((~(Tcl_WideUInt)0) >> 1) + signum)) {
+ objPtr->typePtr = &tclWideIntType;
+ if (signum) {
+ objPtr->internalRep.wideValue =
+ - (Tcl_WideInt) significandWide;
+ } else {
+ objPtr->internalRep.wideValue =
+ (Tcl_WideInt) significandWide;
+ }
+ break;
+ }
+#endif
+ TclBNInitBignumFromWideUInt(&significandBig,
+ significandWide);
+ significandOverflow = 1;
+ } else {
+ objPtr->typePtr = &tclIntType;
+ if (signum) {
+ objPtr->internalRep.longValue =
+ - (long) significandWide;
+ } else {
+ objPtr->internalRep.longValue =
+ (long) significandWide;
+ }
+ }
+ }
+ if (significandOverflow) {
+ if (signum) {
+ mp_neg(&significandBig, &significandBig);
+ }
+ TclSetBignumIntRep(objPtr, &significandBig);
+ }
+ break;
+
+ case FRACTION:
+ case EXPONENT:
+
+ /*
+ * Here, we're parsing a floating-point number.
+ * 'significandWide' or 'significandBig' contains the
+ * exact significand, according to whether
+ * 'significandOverflow' is set. The desired floating
+ * point value is significand * 10**k, where
+ * k = numTrailZeros+exponent-numDigitsAfterDp.
+ */
+
+ objPtr->typePtr = &tclDoubleType;
+ if ( exponentSignum ) {
+ exponent = - exponent;
+ }
+ if ( !significandOverflow ) {
+ objPtr->internalRep.doubleValue =
+ MakeLowPrecisionDouble( signum,
+ significandWide,
+ numSigDigs,
+ ( numTrailZeros
+ + exponent
+ - numDigitsAfterDp ) );
+ } else {
+ objPtr->internalRep.doubleValue =
+ MakeHighPrecisionDouble( signum,
+ &significandBig,
+ numSigDigs,
+ ( numTrailZeros
+ + exponent
+ - numDigitsAfterDp ) );
+ }
+ break;
+
+ case sINF:
+ case sINFINITY:
+ if ( signum ) {
+ objPtr->internalRep.doubleValue = -HUGE_VAL;
+ } else {
+ objPtr->internalRep.doubleValue = HUGE_VAL;
+ }
+ objPtr->typePtr = &tclDoubleType;
+ break;
+
+ case sNAN:
+ case sNANFINISH:
+ objPtr->internalRep.doubleValue
+ = MakeNaN( signum, significandWide );
+ objPtr->typePtr = &tclDoubleType;
+ break;
+
}
}
- /*
- * We don't have one of the easy cases, so we can't compute the scanned
- * number exactly, and have to do it in multiple precision. Begin by
- * testing for obvious overflows and underflows.
- */
+ /* Format an error message when an invalid number is encountered. */
+
+ if ( status != TCL_OK ) {
+ if ( interp != NULL ) {
+ Tcl_Obj *msg = Tcl_NewStringObj( "expected ", -1 );
+ Tcl_AppendToObj( msg, type, -1 );
+ Tcl_AppendToObj( msg, " but got \"", -1 );
+ TclAppendLimitedToObj( msg, string, length, 50, "" );
+ Tcl_AppendToObj( msg, "\"", -1 );
+ if ( state == BAD_OCTAL ) {
+ Tcl_AppendToObj( msg, " (looks like invalid octal number)",
+ -1 );
+ }
+ Tcl_SetObjResult( interp, msg );
+ }
+ }
- if (nSigDigs + exponent - 1 > maxDigits) {
- v = HUGE_VAL;
- errno = ERANGE;
- goto returnValue;
+ /* Free memory */
+
+ if (octalSignificandOverflow) {
+ mp_clear(&octalSignificandBig);
}
- if (nSigDigs + exponent - 1 < minDigits) {
- errno = ERANGE;
- v = 0.;
- goto returnValue;
+ if (significandOverflow) {
+ mp_clear(&significandBig);
}
+ return status;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * AccumulateDecimalDigit --
+ *
+ * Consume a decimal digit in a number being scanned.
+ *
+ * Results:
+ * Returns 1 if the number has overflowed to a bignum, 0 if it
+ * still fits in a wide integer.
+ *
+ * Side effects:
+ * Updates either the wide or bignum representation.
+ *
+ *----------------------------------------------------------------------
+ */
- /*
- * Nothing exceeds the boundaries of the tables, at least. Compute an
- * approximate value for the number, with no possibility of overflow
- * because we manage the exponent separately.
- */
-
- if (nSigDigs > DBL_DIG) {
- expt2 = exponent + nSigDigs - DBL_DIG;
- } else {
- expt2 = exponent;
- }
- v = frexp(exactSignificand, &machexp);
- if (expt2 > 0) {
- v = frexp(v * pow10[expt2 & 0xf], &j);
- machexp += j;
- for (i=4 ; i<9 ; ++i) {
- if (expt2 & (1 << i)) {
- v = frexp(v * pow_10_2_n[i], &j);
- machexp += j;
+static int
+AccumulateDecimalDigit( unsigned digit,
+ /* Digit being scanned */
+ int numZeros,
+ /* Count of zero digits preceding the
+ * digit being scanned */
+ Tcl_WideUInt* wideRepPtr,
+ /* Representation of the partial number
+ * as a wide integer */
+ mp_int* bignumRepPtr,
+ /* Representation of the partial number
+ * as a bignum */
+ int bignumFlag )
+ /* Flag == 1 if the number overflowed
+ * previous to this digit. */
+{
+ int i, n;
+
+ /* Check if the number still fits in a wide */
+
+ if (!bignumFlag) {
+ if (*wideRepPtr != 0) {
+ if ((numZeros >= maxpow10_wide)
+ || (*wideRepPtr > (((~(Tcl_WideUInt)0) - digit)
+ / pow10_wide[numZeros+1]))) {
+ /* Oops, it's overflowed, have to allocate a bignum */
+ TclBNInitBignumFromWideUInt (bignumRepPtr, *wideRepPtr);
+ bignumFlag = 1;
}
}
+ }
+
+ /* Multiply the number by 10**numZeros+1 and add in the new digit. */
+
+ if (!bignumFlag) {
+
+ /* Wide multiplication */
+
+ *wideRepPtr = *wideRepPtr * pow10_wide[numZeros+1] + digit;
+ } else if (numZeros < log10_DIGIT_MAX ) {
+
+ /* Up to about 8 zeros - single digit multiplication */
+
+ mp_mul_d (bignumRepPtr, (mp_digit) pow10_wide[numZeros+1],
+ bignumRepPtr);
+ mp_add_d (bignumRepPtr, (mp_digit) digit, bignumRepPtr);
+
} else {
- v = frexp(v / pow10[(-expt2) & 0xf], &j);
- machexp += j;
- for (i=4 ; i<9 ; ++i) {
- if ((-expt2) & (1 << i)) {
- v = frexp(v / pow_10_2_n[i], &j);
- machexp += j;
+
+ /*
+ * More than single digit multiplication. Multiply by the appropriate
+ * small powers of 5, and then shift. Large strings of zeroes are
+ * eaten 256 at a time; this is less efficient than it could be,
+ * but seems implausible. We presume that DIGIT_BIT is at least 27.
+ * The first multiplication, by up to 10**7, is done with a
+ * one-DIGIT multiply (this presumes that DIGIT_BIT >= 24).
+ */
+
+ n = numZeros + 1;
+ mp_mul_d (bignumRepPtr, (mp_digit) pow10_wide[n&0x7], bignumRepPtr);
+ for (i = 3; i <= 7; ++i) {
+ if (n & (1 << i)) {
+ mp_mul (bignumRepPtr, pow5+i, bignumRepPtr);
}
}
+ while (n >= 256) {
+ mp_mul (bignumRepPtr, pow5+8, bignumRepPtr);
+ n -= 256;
+ }
+ mp_mul_2d (bignumRepPtr, (int)(numZeros+1)&~0x7, bignumRepPtr);
}
+ return bignumFlag;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * MakeLowPrecisionDouble --
+ *
+ * Makes the double precision number, signum*significand*10**exponent.
+ *
+ * Results:
+ * Returns the constructed number.
+ *
+ * Common cases, where there are few enough digits that the number can
+ * be represented with at most roundoff, are handled specially here.
+ * If the number requires more than one rounded operation to compute,
+ * the code promotes the significand to a bignum and calls
+ * MakeHighPrecisionDouble to do it instead.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static double
+MakeLowPrecisionDouble( int signum,
+ /* 1 if the number is negative, 0 otherwise */
+ Tcl_WideUInt significand,
+ /* Significand of the number */
+ int numSigDigs,
+ /* Number of digits in the significand */
+ int exponent )
+ /* Power of ten */
+{
+ double retval; /* Value of the number */
+ mp_int significandBig; /* Significand expressed as a bignum */
+
/*
- * A first approximation is that the result will be v * 2 ** machexp. v is
- * greater than or equal to 0.5 and less than 1. If machexp >
- * DBL_MAX_EXP*log2(FLT_RADIX), there is an overflow. Constrain the result
- * to the smallest representible number to avoid premature underflow.
+ * With gcc on x86, the floating point rounding mode is double-extended.
+ * This causes the result of double-precision calculations to be rounded
+ * twice: once to the precision of double-extended and then again to the
+ * precision of double. Double-rounding introduces gratuitous errors of
+ * 1 ulp, so we need to change rounding mode to 53-bits.
*/
- if (machexp > DBL_MAX_EXP * log2FLT_RADIX) {
- v = HUGE_VAL;
- errno = ERANGE;
- goto returnValue;
- }
+#if defined(__GNUC__) && defined(__i386)
+ fpu_control_t roundTo53Bits = 0x027f;
+ fpu_control_t oldRoundingMode;
+ _FPU_GETCW( oldRoundingMode );
+ _FPU_SETCW( roundTo53Bits );
+#endif
- v = SafeLdExp(v, machexp);
- if (v < tiny) {
- v = tiny;
- }
+ /* Test for the easy cases */
- /*
- * We have a first approximation in v. Now we need to refine it.
- */
+ if ( numSigDigs <= DBL_DIG ) {
+ if ( exponent >= 0 ) {
+ if ( exponent <= mmaxpow ) {
- v = RefineResult(v, startOfSignificand, nSigDigs, exponent);
+ /*
+ * The significand is an exact integer, and so is
+ * 10**exponent. The product will be correct to within
+ * 1/2 ulp without special handling.
+ */
- /*
- * In a very few cases, a second iteration is needed. e.g., 457e-102
- */
+ retval = (double)(Tcl_WideInt)significand * pow10[ exponent ];
+ goto returnValue;
- v = RefineResult(v, startOfSignificand, nSigDigs, exponent);
+ } else {
+ int diff = DBL_DIG - numSigDigs;
+ if ( exponent-diff <= mmaxpow ) {
+
+ /*
+ * 10**exponent is not an exact integer, but
+ * 10**(exponent-diff) is exact, and so is
+ * significand*10**diff, so we can still compute
+ * the value with only one roundoff.
+ */
+ volatile double factor
+ = (double)(Tcl_WideInt)significand * pow10[diff];
+ retval = factor * pow10[exponent-diff];
+ goto returnValue;
+ }
+ }
+ } else {
+ if ( exponent >= -mmaxpow ) {
+
+ /*
+ * 10**-exponent is an exact integer, and so is the
+ * significand. Compute the result by one division,
+ * again with only one rounding.
+ */
+
+ retval = (double)(Tcl_WideInt)significand / pow10[-exponent];
+ goto returnValue;
+ }
+ }
+ }
/*
- * Handle underflow.
+ * All the easy cases have failed. Promote ths significand
+ * to bignum and call MakeHighPrecisionDouble to do it the hard way.
*/
+ TclBNInitBignumFromWideUInt (&significandBig, significand);
+ retval = MakeHighPrecisionDouble( 0, &significandBig, numSigDigs,
+ exponent );
+
+ /* Come here to return the computed value */
+
returnValue:
- if (nSigDigs != 0 && v == 0.0) {
- errno = ERANGE;
+
+ if ( signum ) {
+ retval = -retval;
}
+ /* On gcc on x86, restore the floating point mode word. */
+
+#if defined(__GNUC__) && defined(__i386)
+ _FPU_SETCW( oldRoundingMode );
+#endif
+
+ return retval;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * MakeHighPrecisionDouble --
+ *
+ * Makes the double precision number, signum*significand*10**exponent.
+ *
+ * Results:
+ * Returns the constructed number.
+ *
+ * MakeHighPrecisionDouble is used when arbitrary-precision arithmetic
+ * is needed to ensure correct rounding. It begins by calculating a
+ * low-precision approximation to the desired number, and then refines
+ * the answer in high precision.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static double
+MakeHighPrecisionDouble( int signum,
+ /* 1=negative, 0=nonnegative */
+ mp_int* significand,
+ /* Exact significand of the number */
+ int numSigDigs,
+ /* Number of significant digits */
+ int exponent )
+ /* Power of 10 by which to multiply */
+{
+
+ double retval;
+ int machexp; /* Machine exponent of a power of 10 */
+
/*
- * Return a number with correct sign.
+ * With gcc on x86, the floating point rounding mode is double-extended.
+ * This causes the result of double-precision calculations to be rounded
+ * twice: once to the precision of double-extended and then again to the
+ * precision of double. Double-rounding introduces gratuitous errors of
+ * 1 ulp, so we need to change rounding mode to 53-bits.
*/
- if (signum) {
- v = -v;
+#if defined(__GNUC__) && defined(__i386)
+ fpu_control_t roundTo53Bits = 0x027f;
+ fpu_control_t oldRoundingMode;
+ _FPU_GETCW( oldRoundingMode );
+ _FPU_SETCW( roundTo53Bits );
+#endif
+
+ /* Quick checks for over/underflow */
+
+ if ( numSigDigs + exponent - 1 > maxDigits ) {
+ retval = HUGE_VAL;
+ goto returnValue;
+ }
+ if ( numSigDigs + exponent - 1 < minDigits ) {
+ retval = 0;
+ goto returnValue;
}
- /*
- * Restore FPU mode word and return.
+ /*
+ * Develop a first approximation to the significand. It is tempting
+ * simply to force bignum to double, but that will overflow on input
+ * numbers like 1.[string repeat 0 1000]1; while this is a not terribly
+ * likely scenario, we still have to deal with it. Use fraction and
+ * exponent instead. Once we have the significand, multiply by
+ * 10**exponent. Test for overflow. Convert back to a double, and
+ * test for underflow.
*/
- RestoreRoundingMode();
- return v;
+ retval = BignumToBiasedFrExp( significand, &machexp );
+ retval = Pow10TimesFrExp( exponent, retval, &machexp );
+ if ( machexp > DBL_MAX_EXP * log2FLT_RADIX ) {
+ retval = HUGE_VAL;
+ goto returnValue;
+ }
+ retval = SafeLdExp( retval, machexp );
+ if ( retval < tiny ) {
+ retval = tiny;
+ }
- /*
- * Come here on an invalid input.
+ /*
+ * Refine the result twice. (The second refinement should be
+ * necessary only if the best approximation is a power of 2
+ * minus 1/2 ulp).
*/
- error:
- if (endPtr != NULL) {
- *endPtr = s;
+ retval = RefineApproximation( retval, significand, exponent );
+ retval = RefineApproximation( retval, significand, exponent );
+
+ /* Come here to return the computed value */
+
+ returnValue:
+ if ( signum ) {
+ retval = -retval;
}
- /*
- * Restore FPU mode word and return.
- */
+ /* On gcc on x86, restore the floating point mode word. */
- RestoreRoundingMode();
- return 0.0;
+#if defined(__GNUC__) && defined(__i386)
+ _FPU_SETCW( oldRoundingMode );
+#endif
+ return retval;
}
/*
*----------------------------------------------------------------------
*
- * RefineResult --
+ * MakeNaN --
+ *
+ * Makes a "Not a Number" given a set of bits to put in the
+ * tag bits
*
- * Given a poor approximation to a floating point number, returns a
- * better one. (The better approximation is correct to within 1 ulp, and
- * is entirely correct if the poor approximation is correct to 1 ulp.)
+ * Note that a signalling NaN is never returned.
+ *
+ *----------------------------------------------------------------------
+ */
+
+#ifdef IEEE_FLOATING_POINT
+static double
+MakeNaN( int signum, /* Sign bit (1=negative, 0=nonnegative */
+ Tcl_WideUInt tags ) /* Tag bits to put in the NaN */
+{
+ union {
+ Tcl_WideUInt iv;
+ double dv;
+ } theNaN;
+
+ theNaN.iv = tags;
+ theNaN.iv &= ( ((Tcl_WideUInt) 1) << 51 ) - 1;
+ if ( signum ) {
+ theNaN.iv |= ((Tcl_WideUInt) (0x8000 | NAN_START)) << 48;
+ } else {
+ theNaN.iv |= ((Tcl_WideUInt) NAN_START) << 48;
+ }
+
+ return theNaN.dv;
+}
+#endif
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * RefineApproximation --
+ *
+ * Given a poor approximation to a floating point number, returns
+ * a better one (The better approximation is correct to within
+ * 1 ulp, and is entirely correct if the poor approximation is
+ * correct to 1 ulp.)
*
* Results:
* Returns the improved result.
@@ -534,119 +1528,109 @@ TclStrToD(CONST char *s, /* String to scan. */
*/
static double
-RefineResult(double approxResult, /* Approximate result of conversion. */
- CONST char* sigStart,
- /* Pointer to start of significand in input
- * string. */
- int nSigDigs, /* Number of significant digits. */
- long exponent) /* Power of ten to multiply by significand. */
+RefineApproximation( double approxResult,
+ /* Approximate result of conversion */
+ mp_int* exactSignificand,
+ /* Integer significand */
+ int exponent )
+ /* Power of 10 to multiply by significand */
{
- int M2, M5; /* Powers of 2 and of 5 needed to put the
- * decimal and binary numbers over a common
- * denominator. */
- double significand; /* Sigificand of the binary number. */
- int binExponent; /* Exponent of the binary number. */
+
+ int M2, M5; /* Powers of 2 and of 5 needed to put
+ * the decimal and binary numbers over
+ * a common denominator. */
+ double significand; /* Sigificand of the binary number */
+ int binExponent; /* Exponent of the binary number */
+
int msb; /* Most significant bit position of an
- * intermediate result. */
+ * intermediate result */
int nDigits; /* Number of mp_digit's in an intermediate
- * result. */
- mp_int twoMv; /* Approx binary value expressed as an exact
- * integer scaled by the multiplier 2M. */
- mp_int twoMd; /* Exact decimal value expressed as an exact
- * integer scaled by the multiplier 2M. */
- int scale; /* Scale factor for M. */
- int multiplier; /* Power of two to scale M. */
- double num, den; /* Numerator and denominator of the correction
- * term. */
- double quot; /* Correction term. */
- double minincr; /* Lower bound on the absolute value of the
- * correction term. */
+ * result */
+ mp_int twoMv; /* Approx binary value expressed as an
+ * exact integer scaled by the multiplier 2M */
+ mp_int twoMd; /* Exact decimal value expressed as an
+ * exact integer scaled by the multiplier 2M */
+ int scale; /* Scale factor for M */
+ int multiplier; /* Power of two to scale M */
+ double num, den; /* Numerator and denominator of the
+ * correction term */
+ double quot; /* Correction term */
+ double minincr; /* Lower bound on the absolute value
+ * of the correction term. */
int i;
- const char* p;
/*
- * The first approximation is always low. If we find that it's HUGE_VAL,
- * we're done.
+ * The first approximation is always low. If we find that
+ * it's HUGE_VAL, we're done.
*/
- if (approxResult == HUGE_VAL) {
+ if ( approxResult == HUGE_VAL ) {
return approxResult;
}
/*
- * Find a common denominator for the decimal and binary fractions. The
- * common denominator will be 2**M2 + 5**M5.
+ * Find a common denominator for the decimal and binary fractions.
+ * The common denominator will be 2**M2 + 5**M5.
*/
- significand = frexp(approxResult, &binExponent);
+ significand = frexp( approxResult, &binExponent );
i = mantBits - binExponent;
- if (i < 0) {
+ if ( i < 0 ) {
M2 = 0;
} else {
M2 = i;
}
- if (exponent > 0) {
+ if ( exponent > 0 ) {
M5 = 0;
} else {
M5 = -exponent;
- if ((M5-1) > M2) {
+ if ( (M5-1) > M2 ) {
M2 = M5-1;
}
}
- /*
- * The floating point number is significand*2**binExponent. The 2**-1 bit
- * of the significand (the most significant) corresponds to the
- * 2**(binExponent+M2 + 1) bit of 2*M2*v. Allocate enough digits to hold
- * that quantity, then convert the significand to a large integer, scaled
+ /*
+ * The floating point number is significand*2**binExponent.
+ * Compute the large integer significand*2**(binExponent+M2+1)
+ * The 2**-1 bit of the significand (the most significant)
+ * corresponds to the 2**(binExponent+M2 + 1) bit of 2*M2*v.
+ * Allocate enough digits to hold that quantity, then
+ * convert the significand to a large integer, scaled
* appropriately. Then multiply by the appropriate power of 5.
*/
- msb = binExponent + M2; /* 1008 */
+ msb = binExponent + M2; /* 1008 */
nDigits = msb / DIGIT_BIT + 1;
- mp_init_size(&twoMv, nDigits);
- i = (msb % DIGIT_BIT + 1);
+ mp_init_size( &twoMv, nDigits );
+ i = ( msb % DIGIT_BIT + 1 );
twoMv.used = nDigits;
- significand *= SafeLdExp(1.0, i);
- while (--nDigits >= 0) {
+ significand *= SafeLdExp( 1.0, i );
+ while ( -- nDigits >= 0 ) {
twoMv.dp[nDigits] = (mp_digit) significand;
significand -= (mp_digit) significand;
- significand = SafeLdExp(significand, DIGIT_BIT);
+ significand = SafeLdExp( significand, DIGIT_BIT );
}
- for (i=0 ; i<=8 ; ++i) {
- if (M5 & (1 << i)) {
- mp_mul(&twoMv, pow5+i, &twoMv);
+ for ( i = 0; i <= 8; ++i ) {
+ if ( M5 & ( 1 << i ) ) {
+ mp_mul( &twoMv, pow5+i, &twoMv );
}
}
-
- /*
- * Collect the decimal significand as a high precision integer. The least
- * significant bit corresponds to bit M2+exponent+1 so it will need to be
- * shifted left by that many bits after being multiplied by
- * 5**(M5+exponent).
+
+ /*
+ * Collect the decimal significand as a high precision integer.
+ * The least significant bit corresponds to bit M2+exponent+1
+ * so it will need to be shifted left by that many bits after
+ * being multiplied by 5**(M5+exponent).
*/
- mp_init(&twoMd);
- mp_zero(&twoMd);
- i = nSigDigs;
- for (p=sigStart ;; ++p) {
- char c = *p;
- if (isdigit(UCHAR(c))) {
- mp_mul_d(&twoMd, (unsigned) 10, &twoMd);
- mp_add_d(&twoMd, (unsigned) (c - '0'), &twoMd);
- --i;
- if (i == 0) {
- break;
- }
- }
- }
- for (i=0 ; i<=8 ; ++i) {
- if ((M5+exponent) & (1 << i)) {
- mp_mul(&twoMd, pow5+i, &twoMd);
+ mp_init_copy( &twoMd, exactSignificand );
+ for ( i = 0; i <= 8; ++i ) {
+ if ( (M5+exponent) & ( 1 << i ) ) {
+ mp_mul( &twoMd, pow5+i, &twoMd );
}
}
- mp_mul_2d(&twoMd, M2+exponent+1, &twoMd);
- mp_sub(&twoMd, &twoMv, &twoMd);
+ mp_mul_2d( &twoMd, M2+exponent+1, &twoMd );
+ mp_sub( &twoMd, &twoMv, &twoMd );
/*
* The result, 2Mv-2Md, needs to be divided by 2M to yield a correction
@@ -656,135 +1640,55 @@ RefineResult(double approxResult, /* Approximate result of conversion. */
scale = binExponent - mantBits - 1;
- mp_set(&twoMv, 1);
- for (i=0 ; i<=8 ; ++i) {
- if (M5 & (1 << i)) {
- mp_mul(&twoMv, pow5+i, &twoMv);
+ mp_set( &twoMv, 1 );
+ for ( i = 0; i <= 8; ++i ) {
+ if ( M5 & ( 1 << i ) ) {
+ mp_mul( &twoMv, pow5+i, &twoMv );
}
}
multiplier = M2 + scale + 1;
- if (multiplier > 0) {
- mp_mul_2d(&twoMv, multiplier, &twoMv);
- } else if (multiplier < 0) {
- mp_div_2d(&twoMv, -multiplier, &twoMv, NULL);
+ if ( multiplier > 0 ) {
+ mp_mul_2d( &twoMv, multiplier, &twoMv );
+ } else if ( multiplier < 0 ) {
+ mp_div_2d( &twoMv, -multiplier, &twoMv, NULL );
}
/*
- * If the result is less than unity, the error is less than 1/2 unit in
- * the last place, so there's no correction to make.
+ * If the result is less than unity, the error is less than 1/2 unit
+ * in the last place, so there's no correction to make.
*/
- if (mp_cmp_mag(&twoMd, &twoMv) == MP_LT) {
- mp_clear(&twoMd);
- mp_clear(&twoMv);
+ if ( mp_cmp_mag( &twoMd, &twoMv ) == MP_LT ) {
return approxResult;
}
- /*
- * Convert the numerator and denominator of the corrector term accurately
- * to floating point numbers.
+ /*
+ * Convert the numerator and denominator of the corrector term
+ * accurately to floating point numbers.
*/
- num = TclBignumToDouble(&twoMd);
- den = TclBignumToDouble(&twoMv);
+ num = TclBignumToDouble( &twoMd );
+ den = TclBignumToDouble( &twoMv );
- quot = SafeLdExp(num/den, scale);
- minincr = SafeLdExp(1.0, binExponent - mantBits);
+ quot = SafeLdExp( num/den, scale );
+ minincr = SafeLdExp( 1.0, binExponent - mantBits );
- if (quot<0. && quot>-minincr) {
+ if ( quot < 0. && quot > -minincr ) {
quot = -minincr;
- } else if (quot>0. && quot<minincr) {
+ } else if ( quot > 0. && quot < minincr ) {
quot = minincr;
}
- mp_clear(&twoMd);
- mp_clear(&twoMv);
+ mp_clear( &twoMd );
+ mp_clear( &twoMv );
+
return approxResult + quot;
}
/*
*----------------------------------------------------------------------
*
- * ParseNaN --
- *
- * Parses a "not a number" from an input string, and returns the double
- * precision NaN corresponding to it.
- *
- * Side effects:
- * Advances endPtr to follow any (hex) in the input string.
- *
- * If the NaN is followed by a left paren, a string of spaes and
- * hexadecimal digits, and a right paren, endPtr is advanced to follow
- * it.
- *
- * The string of hexadecimal digits is OR'ed into the resulting NaN, and
- * the signum is set as well. Note that a signalling NaN is never
- * returned.
- *
- *----------------------------------------------------------------------
- */
-
-static double
-ParseNaN(int signum, /* Flag == 1 if minus sign has been seen in
- * front of NaN. */
- CONST char** endPtr) /* Pointer-to-pointer to char following "NaN"
- * in the input string. */
-{
- const char* p = *endPtr;
- char c;
- union {
- Tcl_WideUInt iv;
- double dv;
- } theNaN;
-
- /*
- * Scan off a hex number in parentheses. Embedded blanks are ok.
- */
-
- theNaN.iv = 0;
- if (*p == '(') {
- ++p;
- for (;;) {
- c = *p++;
- if (isspace(UCHAR(c))) {
- continue;
- } else if (c == ')') {
- *endPtr = p;
- break;
- } else if (isdigit(UCHAR(c))) {
- c -= '0';
- } else if (c >= 'A' && c <= 'F') {
- c -= 'A' + 10;
- } else if (c >= 'a' && c <= 'f') {
- c -= 'a' + 10;
- } else {
- theNaN.iv = (((Tcl_WideUInt) NAN_START) << 48)
- | (((Tcl_WideUInt) signum) << 63);
- return theNaN.dv;
- }
- theNaN.iv = (theNaN.iv << 4) | c;
- }
- }
-
- /*
- * Mask the hex number down to the least significant 51 bits.
- */
-
- theNaN.iv &= (((Tcl_WideUInt) 1) << 51) - 1;
- if (signum) {
- theNaN.iv |= ((Tcl_WideUInt) 0xfff8) << 48;
- } else {
- theNaN.iv |= ((Tcl_WideUInt) NAN_START) << 48;
- }
-
- *endPtr = p;
- return theNaN.dv;
-}
-
-/*
- *----------------------------------------------------------------------
- *
* TclDoubleDigits --
*
* Converts a double to a string of digits.
@@ -803,20 +1707,21 @@ ParseNaN(int signum, /* Flag == 1 if minus sign has been seen in
*/
int
-TclDoubleDigits(char * strPtr, /* Buffer in which to store the result, must
- * have at least 18 chars. */
- double v, /* Number to convert. Must be finite, and not
- * NaN. */
- int *signum) /* Output: 1 if the number is negative.
- * Should handle -0 correctly on the IEEE
- * architecture. */
+TclDoubleDigits( char * string, /* Buffer in which to store the result,
+ * must have at least 18 chars */
+ double v, /* Number to convert. Must be
+ * finite, and not NaN */
+ int *signum ) /* Output: 1 if the number is negative.
+ * Should handle -0 correctly on the
+ * IEEE architecture. */
{
- double f; /* Significand of v. */
int e; /* Power of FLT_RADIX that satisfies
* v = f * FLT_RADIX**e */
int lowOK, highOK;
mp_int r; /* Scaled significand. */
mp_int s; /* Divisor such that v = r / s */
+ int smallestSig; /* Flag == 1 iff v's significand is
+ * the smallest that can be represented. */
mp_int mplus; /* Scaled epsilon: (r + 2* mplus) == v(+)
* where v(+) is the floating point successor
* of v. */
@@ -830,103 +1735,31 @@ TclDoubleDigits(char * strPtr, /* Buffer in which to store the result, must
int sfac5 = 0;
int mplusfac2 = 0;
int mminusfac2 = 0;
- double a;
char c;
int i, k, n;
- /*
- * Take the absolute value of the number, and report the number's sign.
- * Take special steps to preserve signed zeroes in IEEE floating point.
- * (We can't use fpclassify, because that's a C9x feature and we still
- * have to build on C89 compilers.)
- */
+ /* Split the number into absolute value and signum. */
-#ifndef IEEE_FLOATING_POINT
- if (v >= 0.0) {
- *signum = 0;
- } else {
- *signum = 1;
- v = -v;
- }
-#else
- union {
- Tcl_WideUInt iv;
- double dv;
- } bitwhack;
- bitwhack.dv = v;
- if (bitwhack.iv & ((Tcl_WideUInt) 1 << 63)) {
- *signum = 1;
- bitwhack.iv &= ~((Tcl_WideUInt) 1 << 63);
- v = bitwhack.dv;
- } else {
- *signum = 0;
- }
-#endif
+ v = AbsoluteValue(v, signum);
/*
* Handle zero specially.
*/
- if (v == 0.0) {
- *strPtr++ = '0';
- *strPtr++ = '\0';
+ if ( v == 0.0 ) {
+ *string++ = '0';
+ *string++ = '\0';
return 1;
}
- /*
- * Develop f and e such that v = f * FLT_RADIX**e, with
- * 1.0/FLT_RADIX <= f < 1.
+ /*
+ * Find a large integer r, and integer e, such that
+ * v = r * FLT_RADIX**e
+ * and r is as small as possible. Also determine whether the
+ * significand is the smallest possible.
*/
- f = frexp(v, &e);
- n = e % log2FLT_RADIX;
- if (n > 0) {
- n -= log2FLT_RADIX;
- e += 1;
- }
- f *= ldexp(1.0, n);
- e = (e - n) / log2FLT_RADIX;
- if (f == 1.0) {
- f = 1.0 / FLT_RADIX;
- e += 1;
- }
-
- /*
- * If the original number was denormalized, adjust e and f to be denormal
- * as well.
- */
-
- if (e < DBL_MIN_EXP) {
- n = mantBits + (e - DBL_MIN_EXP)*log2FLT_RADIX;
- f = ldexp(f, (e - DBL_MIN_EXP)*log2FLT_RADIX);
- e = DBL_MIN_EXP;
- n = (n + DIGIT_BIT - 1) / DIGIT_BIT;
- } else {
- n = mantDIGIT;
- }
-
- /*
- * Now extract the base-2**DIGIT_BIT digits of f into a multi-precision
- * integer r. Preserve the invariant v = r * 2**rfac2 * FLT_RADIX**e by
- * adjusting e.
- */
-
- a = f;
- n = mantDIGIT;
- mp_init_size(&r, n);
- r.used = n;
- r.sign = MP_ZPOS;
- i = (mantBits % DIGIT_BIT);
- if (i == 0) {
- i = DIGIT_BIT;
- }
- while (n > 0) {
- a *= ldexp(1.0, i);
- i = DIGIT_BIT;
- r.dp[--n] = (mp_digit) a;
- a -= (mp_digit) a;
- }
- e -= DBL_MANT_DIG;
+ smallestSig = GetIntegerTimesPower(v, &r, &e);
lowOK = highOK = (mp_iseven(&r));
@@ -943,12 +1776,12 @@ TclDoubleDigits(char * strPtr, /* Buffer in which to store the result, must
if (e >= 0) {
int bits = e * log2FLT_RADIX;
- if (f != 1.0/FLT_RADIX) {
+ if (!smallestSig) {
/*
* Normal case, m+ and m- are both FLT_RADIX**e
*/
- rfac2 += bits + 1;
+ rfac2 = bits + 1;
sfac2 = 1;
mplusfac2 = bits;
mminusfac2 = bits;
@@ -959,7 +1792,7 @@ TclDoubleDigits(char * strPtr, /* Buffer in which to store the result, must
* smaller exponent when going to e's predecessor.
*/
- rfac2 += bits + log2FLT_RADIX + 1;
+ rfac2 = bits + log2FLT_RADIX + 1;
sfac2 = 1 + log2FLT_RADIX;
mplusfac2 = bits + log2FLT_RADIX;
mminusfac2 = bits;
@@ -969,13 +1802,13 @@ TclDoubleDigits(char * strPtr, /* Buffer in which to store the result, must
* v has digits after the binary point
*/
- if (e <= DBL_MIN_EXP-DBL_MANT_DIG || f != 1.0/FLT_RADIX) {
+ if (e <= DBL_MIN_EXP-DBL_MANT_DIG || !smallestSig) {
/*
* Either f isn't the smallest significand or e is the smallest
* exponent. mplus and mminus will both be 1.
*/
- rfac2 += 1;
+ rfac2 = 1;
sfac2 = 1 - e * log2FLT_RADIX;
mplusfac2 = 0;
mminusfac2 = 0;
@@ -986,7 +1819,7 @@ TclDoubleDigits(char * strPtr, /* Buffer in which to store the result, must
* fact that v's predecessor has a smaller exponent.
*/
- rfac2 += 1 + log2FLT_RADIX;
+ rfac2 = 1 + log2FLT_RADIX;
sfac2 = 1 + log2FLT_RADIX * (1 - e);
mplusfac2 = FLT_RADIX;
mminusfac2 = 0;
@@ -1081,9 +1914,9 @@ TclDoubleDigits(char * strPtr, /* Buffer in which to store the result, must
} else {
tc2= (tc2 > 0);
}
- if (!tc1) {
- if (!tc2) {
- *strPtr++ = '0' + i;
+ if ( ! tc1 ) {
+ if ( !tc2 ) {
+ *string++ = '0' + i;
} else {
c = (char) (i + '1');
break;
@@ -1103,8 +1936,8 @@ TclDoubleDigits(char * strPtr, /* Buffer in which to store the result, must
break;
}
};
- *strPtr++ = c;
- *strPtr++ = '\0';
+ *string++ = c;
+ *string++ = '\0';
/*
* Free memory, and return.
@@ -1117,6 +1950,148 @@ TclDoubleDigits(char * strPtr, /* Buffer in which to store the result, must
/*
*----------------------------------------------------------------------
*
+ * AbsoluteValue --
+ *
+ * Splits a 'double' into its absolute value and sign.
+ *
+ * Results:
+ * Returns the absolute value.
+ *
+ * Side effects:
+ * Stores the signum in '*signum'.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static double
+AbsoluteValue (double v, /* Number to split */
+ int* signum) /* (Output) Sign of the number 1=-, 0=+ */
+{
+ /*
+ * Take the absolute value of the number, and report the number's sign.
+ * Take special steps to preserve signed zeroes in IEEE floating point.
+ * (We can't use fpclassify, because that's a C9x feature and we still
+ * have to build on C89 compilers.)
+ */
+
+#ifndef IEEE_FLOATING_POINT
+ if (v >= 0.0) {
+ *signum = 0;
+ } else {
+ *signum = 1;
+ v = -v;
+ }
+#else
+ union {
+ Tcl_WideUInt iv;
+ double dv;
+ } bitwhack;
+ bitwhack.dv = v;
+ if (bitwhack.iv & ((Tcl_WideUInt) 1 << 63)) {
+ *signum = 1;
+ bitwhack.iv &= ~((Tcl_WideUInt) 1 << 63);
+ v = bitwhack.dv;
+ } else {
+ *signum = 0;
+ }
+#endif
+ return v;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * GetIntegerTimesPower --
+ *
+ * Converts a floating point number to an exact integer times a
+ * power of the floating point radix.
+ *
+ * Results:
+ * Returns 1 if it converted the smallest significand, 0 otherwise.
+ *
+ * Side effects:
+ * Initializes the integer value (does not just assign it),
+ * and stores the exponent.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+GetIntegerTimesPower(double v, /* Value to convert */
+ mp_int* rPtr,
+ /* (Output) Integer value */
+ int* ePtr) /* (Output) Power of FLT_RADIX by which
+ * r must be multiplied to yield v*/
+{
+
+ double a;
+ double f;
+ int e;
+ int i;
+ int n;
+
+ /*
+ * Develop f and e such that v = f * FLT_RADIX**e, with
+ * 1.0/FLT_RADIX <= f < 1.
+ */
+
+ f = frexp(v, &e);
+#if FLT_RADIX > 2
+ n = e % log2FLT_RADIX;
+ if (n > 0) {
+ n -= log2FLT_RADIX;
+ e += 1;
+ f *= ldexp(1.0, n);
+ }
+ e = (e - n) / log2FLT_RADIX;
+#endif
+ if (f == 1.0) {
+ f = 1.0 / FLT_RADIX;
+ e += 1;
+ }
+
+ /*
+ * If the original number was denormalized, adjust e and f to be denormal
+ * as well.
+ */
+
+ if (e < DBL_MIN_EXP) {
+ n = mantBits + (e - DBL_MIN_EXP)*log2FLT_RADIX;
+ f = ldexp(f, (e - DBL_MIN_EXP)*log2FLT_RADIX);
+ e = DBL_MIN_EXP;
+ n = (n + DIGIT_BIT - 1) / DIGIT_BIT;
+ } else {
+ n = mantDIGIT;
+ }
+
+ /*
+ * Now extract the base-2**DIGIT_BIT digits of f into a multi-precision
+ * integer r. Preserve the invariant v = r * 2**rfac2 * FLT_RADIX**e by
+ * adjusting e.
+ */
+
+ a = f;
+ n = mantDIGIT;
+ mp_init_size(rPtr, n);
+ rPtr->used = n;
+ rPtr->sign = MP_ZPOS;
+ i = (mantBits % DIGIT_BIT);
+ if (i == 0) {
+ i = DIGIT_BIT;
+ }
+ while (n > 0) {
+ a *= ldexp(1.0, i);
+ i = DIGIT_BIT;
+ rPtr->dp[--n] = (mp_digit) a;
+ a -= (mp_digit) a;
+ }
+ *ePtr = e - DBL_MANT_DIG;
+ return (f == 1.0 / FLT_RADIX);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* TclInitDoubleConversion --
*
* Initializes constants that are needed for conversions to and from
@@ -1138,16 +2113,43 @@ TclInitDoubleConversion(void)
{
int i;
int x;
+ Tcl_WideUInt u;
double d;
- if (frexp((double) FLT_RADIX, &log2FLT_RADIX) != 0.5) {
- Tcl_Panic("This code doesn't work on a decimal machine!");
+ /*
+ * Initialize table of powers of 10 expressed as wide integers.
+ */
+
+ maxpow10_wide =
+ (int) floor(sizeof (Tcl_WideUInt) * CHAR_BIT * log (2.) / log (10.));
+ pow10_wide = (Tcl_WideUInt*) Tcl_Alloc ((maxpow10_wide + 1)
+ * sizeof (Tcl_WideUInt));
+ u = 1;
+ for (i = 0; i < maxpow10_wide; ++i) {
+ pow10_wide[i] = u;
+ u *= 10;
+ }
+ pow10_wide[i] = u;
+
+ /*
+ * Determine how many bits of precision a double has, and how many
+ * decimal digits that represents.
+ */
+
+ if ( frexp( (double) FLT_RADIX, &log2FLT_RADIX ) != 0.5 ) {
+ Tcl_Panic( "This code doesn't work on a decimal machine!" );
}
--log2FLT_RADIX;
mantBits = DBL_MANT_DIG * log2FLT_RADIX;
d = 1.0;
- x = (int) (DBL_MANT_DIG * log((double) FLT_RADIX) / log(5.0));
- if (x < MAXPOW) {
+
+ /*
+ * Initialize a table of powers of ten that can be exactly represented
+ * in a double.
+ */
+
+ x = (int) (DBL_MANT_DIG * log((double) FLT_RADIX) / log( 5.0 ));
+ if ( x < MAXPOW ) {
mmaxpow = x;
} else {
mmaxpow = MAXPOW;
@@ -1156,19 +2158,32 @@ TclInitDoubleConversion(void)
pow10[i] = d;
d *= 10.0;
}
- for (i=0 ; i<9 ; ++i) {
- mp_init(pow5 + i);
+
+ /* Initialize a table of large powers of five. */
+
+ for ( i = 0; i < 9; ++i ) {
+ mp_init( pow5 + i );
}
- mp_set(pow5, 5);
- for (i=0 ; i<8 ; ++i) {
- mp_sqr(pow5+i, pow5+i+1);
+ mp_set( pow5, 5 );
+ for ( i = 0; i < 8; ++i ) {
+ mp_sqr( pow5+i, pow5+i+1 );
}
- tiny = SafeLdExp(1.0, DBL_MIN_EXP * log2FLT_RADIX - mantBits);
- maxDigits = (int)
- ((DBL_MAX_EXP * log((double) FLT_RADIX) + log(10.)/2) / log(10.));
- minDigits = (int)
- floor((DBL_MIN_EXP-DBL_MANT_DIG)*log((double)FLT_RADIX)/log(10.));
- mantDIGIT = (mantBits + DIGIT_BIT - 1) / DIGIT_BIT;
+
+ /*
+ * Determine the number of decimal digits to the left and right of the
+ * decimal point in the largest and smallest double, the smallest double
+ * that differs from zero, and the number of mp_digits needed to represent
+ * the significand of a double.
+ */
+
+ tiny = SafeLdExp( 1.0, DBL_MIN_EXP * log2FLT_RADIX - mantBits );
+ maxDigits = (int) ((DBL_MAX_EXP * log((double) FLT_RADIX)
+ + 0.5 * log(10.))
+ / log( 10. ));
+ minDigits = (int) floor ( ( DBL_MIN_EXP - DBL_MANT_DIG )
+ * log( (double) FLT_RADIX ) / log( 10. ) );
+ mantDIGIT = ( mantBits + DIGIT_BIT - 1 ) / DIGIT_BIT;
+ log10_DIGIT_MAX = (int) floor (DIGIT_BIT * log(2.) / log (10.));
}
/*
@@ -1191,9 +2206,62 @@ void
TclFinalizeDoubleConversion()
{
int i;
- for (i=0 ; i<9 ; ++i) {
- mp_clear(pow5 + i);
+ Tcl_Free ((char*)pow10_wide);
+ for ( i = 0; i < 9; ++i ) {
+ mp_clear( pow5 + i );
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclInitBignumFromDouble --
+ *
+ * Extracts the integer part of a double and converts it to
+ * an arbitrary precision integer.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Initializes the bignum supplied, and stores the converted number
+ * in it.
+ *
+ *----------------------------------------------------------------------
+ */
+
+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 (TclIsInfinite(d)) {
+ 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);
+ mp_zero(b);
+ } else {
+ Tcl_WideInt w = (Tcl_WideInt) ldexp(fract, mantBits);
+ int shift = expt - mantBits;
+ TclBNInitBignumFromWideInt(b, w);
+ if (shift < 0) {
+ mp_div_2d(b, -shift, b, NULL);
+ } else if (shift > 0) {
+ mp_mul_2d(b, shift, b);
+ }
}
+ return TCL_OK;
}
/*
@@ -1228,7 +2296,11 @@ TclBignumToDouble(mp_int *a) /* Integer to convert. */
bits = mp_count_bits(a);
if (bits > DBL_MAX_EXP*log2FLT_RADIX) {
errno = ERANGE;
- return HUGE_VAL;
+ if (a->sign == MP_ZPOS) {
+ return HUGE_VAL;
+ } else {
+ return -HUGE_VAL;
+ }
}
shift = mantBits + 1 - bits;
mp_init(&b);
@@ -1268,6 +2340,210 @@ TclBignumToDouble(mp_int *a) /* Integer to convert. */
return -r;
}
}
+
+double
+TclCeil(mp_int *a) /* Integer to convert. */
+{
+ double r = 0.0;
+ mp_int b;
+
+ mp_init(&b);
+ if (mp_cmp_d(a, 0) == MP_LT) {
+ mp_neg(a, &b);
+ r = -TclFloor(&b);
+ } else {
+ int bits = mp_count_bits(a);
+
+ if (bits > DBL_MAX_EXP*log2FLT_RADIX) {
+ r = HUGE_VAL;
+ } else {
+ int i, exact = 1, shift = mantBits - bits;
+
+ if (shift > 0) {
+ mp_mul_2d(a, shift, &b);
+ } else if (shift < 0) {
+ mp_int d;
+ mp_init(&d);
+ mp_div_2d(a, -shift, &b, &d);
+ exact = mp_iszero(&d);
+ mp_clear(&d);
+ } else {
+ mp_copy(a, &b);
+ }
+ if (!exact) {
+ mp_add_d(&b, 1, &b);
+ }
+ for (i=b.used-1 ; i>=0 ; --i) {
+ r = ldexp(r, DIGIT_BIT) + b.dp[i];
+ }
+ r = ldexp(r, bits - mantBits);
+ }
+ }
+ mp_clear(&b);
+ return r;
+}
+
+double
+TclFloor(mp_int *a) /* Integer to convert. */
+{
+ double r = 0.0;
+ mp_int b;
+
+ mp_init(&b);
+ if (mp_cmp_d(a, 0) == MP_LT) {
+ mp_neg(a, &b);
+ r = -TclCeil(&b);
+ } else {
+ int bits = mp_count_bits(a);
+
+ if (bits > DBL_MAX_EXP*log2FLT_RADIX) {
+ r = DBL_MAX;
+ } else {
+ int i, shift = mantBits - bits;
+
+ if (shift > 0) {
+ mp_mul_2d(a, shift, &b);
+ } else if (shift < 0) {
+ mp_div_2d(a, -shift, &b, NULL);
+ } else {
+ mp_copy(a, &b);
+ }
+ for (i=b.used-1 ; i>=0 ; --i) {
+ r = ldexp(r, DIGIT_BIT) + b.dp[i];
+ }
+ r = ldexp(r, bits - mantBits);
+ }
+ }
+ mp_clear(&b);
+ return r;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * BignumToBiasedFrExp --
+ *
+ * Convert an arbitrary-precision integer to a native floating
+ * point number in the range [0.5,1) times a power of two.
+ * NOTE: Intentionally converts to a number that's a few
+ * ulp too small, so that RefineApproximation will not overflow
+ * near the high end of the machine's arithmetic range.
+ *
+ * Results:
+ * Returns the converted number.
+ *
+ * Side effects:
+ * Stores the exponent of two in 'machexp'.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static double
+BignumToBiasedFrExp( mp_int* a,
+ /* Integer to convert */
+ int* machexp )
+ /* Power of two */
+{
+ mp_int b;
+ int bits;
+ int shift;
+ int i;
+ double r;
+
+ /* Determine how many bits we need, and extract that many from
+ * the input. Round to nearest unit in the last place. */
+
+ bits = mp_count_bits( a );
+ shift = mantBits - 2 - bits;
+ mp_init( &b );
+ if ( shift > 0 ) {
+ mp_mul_2d( a, shift, &b );
+ } else if ( shift < 0 ) {
+ mp_div_2d( a, -shift, &b, NULL );
+ } else {
+ mp_copy( a, &b );
+ }
+
+ /* Accumulate the result, one mp_digit at a time */
+
+ r = 0.0;
+ for ( i = b.used-1; i >= 0; --i ) {
+ r = ldexp( r, DIGIT_BIT ) + b.dp[i];
+ }
+ mp_clear( &b );
+
+ /* Return the result with the appropriate sign. */
+
+ *machexp = bits - mantBits + 2;
+ if ( a->sign == MP_ZPOS ) {
+ return r;
+ } else {
+ return -r;
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Pow10TimesFrExp --
+ *
+ * Multiply a power of ten by a number expressed as fraction and
+ * exponent.
+ *
+ * Results:
+ * Returns the significand of the result.
+ *
+ * Side effects:
+ * Overwrites the 'machexp' parameter with the exponent of the
+ * result.
+ *
+ * Assumes that 'exponent' is such that 10**exponent would be a double,
+ * even though 'fraction*10**(machexp+exponent)' might overflow.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static double
+Pow10TimesFrExp( int exponent, /* Power of 10 to multiply by */
+ double fraction,
+ /* Significand of multiplicand */
+ int* machexp ) /* On input, exponent of multiplicand.
+ * On output, exponent of result. */
+{
+ int i, j;
+ int expt = *machexp;
+ double retval = fraction;
+
+ if ( exponent > 0 ) {
+
+ /* Multiply by 10**exponent */
+
+ retval = frexp( retval * pow10[ exponent & 0xf ], &j );
+ expt += j;
+ for ( i = 4; i < 9; ++i ) {
+ if ( exponent & (1<<i) ) {
+ retval = frexp( retval * pow_10_2_n[ i ], &j );
+ expt += j;
+ }
+ }
+ } else if ( exponent < 0 ) {
+
+ /* Divide by 10**-exponent */
+
+ retval = frexp( retval / pow10[ (-exponent) & 0xf ], &j );
+ expt += j;
+ for ( i = 4; i < 9; ++i ) {
+ if ( (-exponent) & (1<<i) ) {
+ retval = frexp( retval / pow_10_2_n[ i ], &j );
+ expt += j;
+ }
+ }
+ }
+
+ *machexp = expt;
+ return retval;
+
+}
/*
*----------------------------------------------------------------------
diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c
index d5dedc2..74b6f83 100644
--- a/generic/tclStringObj.c
+++ b/generic/tclStringObj.c
@@ -33,9 +33,10 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclStringObj.c,v 1.48 2005/09/15 16:58:24 dgp Exp $ */
+ * RCS: @(#) $Id: tclStringObj.c,v 1.49 2005/10/08 14:42:45 dgp Exp $ */
#include "tclInt.h"
+#include "tommath.h"
/*
* Prototypes for functions defined later in this file:
@@ -386,6 +387,8 @@ Tcl_GetCharLength(objPtr)
* string to count continuous ascii characters before resorting to the
* Tcl_NumUtfChars call. This is a long form of:
stringPtr->numChars = Tcl_NumUtfChars(objPtr->bytes,objPtr->length);
+ *
+ * TODO: Consider macro-izing this.
*/
while (i && (*str < 0xC0)) {
@@ -1722,7 +1725,7 @@ TclAppendFormattedObjs(interp, appendObj, format, objc, objv)
while (*format != '\0') {
char *end;
int gotMinus, gotHash, gotZero, gotSpace, gotPlus, sawFlag;
- int width, gotPrecision, precision, useShort, useWide;
+ int width, gotPrecision, precision, useShort, useWide, useBig;
int newXpg, numChars, allocSegment = 0;
Tcl_Obj *segment;
Tcl_UniChar ch;
@@ -1865,17 +1868,23 @@ TclAppendFormattedObjs(interp, appendObj, format, objc, objv)
/* 5. Length modifier */
- useShort = useWide = 0;
+ useShort = useWide = useBig = 0;
if (ch == 'h') {
useShort = 1;
format += step;
step = Tcl_UtfToUniChar(format, &ch);
} else if (ch == 'l') {
+ format += step;
+ step = Tcl_UtfToUniChar(format, &ch);
+ if (ch == 'l') {
+ useBig = 1;
+ format += step;
+ step = Tcl_UtfToUniChar(format, &ch);
+ } else {
#ifndef TCL_WIDE_INT_IS_LONG
useWide = 1;
#endif
- format += step;
- step = Tcl_UtfToUniChar(format, &ch);
+ }
}
format += step;
@@ -1913,6 +1922,10 @@ TclAppendFormattedObjs(interp, appendObj, format, objc, objv)
}
case 'u':
+ if (useBig) {
+ msg = "unsigned bignum format is invalid";
+ goto errorMsg;
+ }
case 'd':
case 'o':
case 'x':
@@ -1920,26 +1933,54 @@ TclAppendFormattedObjs(interp, appendObj, format, objc, objv)
short int s;
long l;
Tcl_WideInt w;
+ mp_int big;
int isNegative = 0;
- if (useWide) {
- if (Tcl_GetWideIntFromObj(interp, segment, &w) != TCL_OK) {
- goto error;
- }
- } else if (Tcl_GetLongFromObj(NULL, segment, &l) != TCL_OK) {
- if (Tcl_GetWideIntFromObj(interp, segment, &w) != TCL_OK) {
+ if (useBig) {
+ if (Tcl_GetBignumFromObj(interp, segment, &big) != TCL_OK) {
goto error;
}
- l = Tcl_WideAsLong(w);
- }
-
- if (useShort) {
- s = (short int) l;
- isNegative = (s < (short int)0);
+ isNegative = (mp_cmp_d(&big, 0) == MP_LT);
} else if (useWide) {
+ if (Tcl_GetWideIntFromObj(NULL, segment, &w) != TCL_OK) {
+ Tcl_Obj *objPtr;
+ if (Tcl_GetBignumFromObj(interp, segment, &big) != TCL_OK) {
+ goto error;
+ }
+ mp_mod_2d(&big, (int) CHAR_BIT * sizeof(Tcl_WideInt), &big);
+ objPtr = Tcl_NewBignumObj(&big);
+ Tcl_IncrRefCount(objPtr);
+ Tcl_GetWideIntFromObj(NULL, objPtr, &w);
+ Tcl_DecrRefCount(objPtr);
+ }
isNegative = (w < (Tcl_WideInt)0);
+ } else if (Tcl_GetLongFromObj(NULL, segment, &l) != TCL_OK) {
+ if (Tcl_GetWideIntFromObj(NULL, segment, &w) != TCL_OK) {
+ Tcl_Obj *objPtr;
+ if (Tcl_GetBignumFromObj(interp, segment, &big) != TCL_OK) {
+ goto error;
+ }
+ mp_mod_2d(&big, (int) CHAR_BIT * sizeof(long), &big);
+ objPtr = Tcl_NewBignumObj(&big);
+ Tcl_IncrRefCount(objPtr);
+ Tcl_GetLongFromObj(NULL, objPtr, &l);
+ Tcl_DecrRefCount(objPtr);
+ } else {
+ l = Tcl_WideAsLong(w);
+ }
+ if (useShort) {
+ s = (short int) l;
+ isNegative = (s < (short int)0);
+ } else {
+ isNegative = (l < (long)0);
+ }
} else {
- isNegative = (l < (long)0);
+ if (useShort) {
+ s = (short int) l;
+ isNegative = (s < (short int)0);
+ } else {
+ isNegative = (l < (long)0);
+ }
}
segment = Tcl_NewObj();
@@ -1947,7 +1988,7 @@ TclAppendFormattedObjs(interp, appendObj, format, objc, objv)
Tcl_IncrRefCount(segment);
if (isNegative || gotPlus) {
- if (ch == 'd') {
+ if (useBig || (ch == 'd')) {
if (isNegative) {
Tcl_AppendToObj(segment, "-", 1);
} else {
@@ -1975,26 +2016,18 @@ TclAppendFormattedObjs(interp, appendObj, format, objc, objv)
Tcl_Obj *pure;
CONST char *bytes;
- if (isNegative) {
- if (useShort) {
- pure = Tcl_NewIntObj((int)(-s));
- } else if (useWide) {
- pure = Tcl_NewWideIntObj(-w);
- } else {
- pure = Tcl_NewLongObj(-l);
- }
+ if (useShort) {
+ pure = Tcl_NewIntObj((int)(s));
+ } else if (useWide) {
+ pure = Tcl_NewWideIntObj(w);
+ } else if (useBig) {
+ pure = Tcl_NewBignumObj(&big);
} else {
- if (useShort) {
- pure = Tcl_NewIntObj((int)(s));
- } else if (useWide) {
- pure = Tcl_NewWideIntObj(w);
- } else {
- pure = Tcl_NewLongObj(l);
- }
+ pure = Tcl_NewLongObj(l);
}
Tcl_IncrRefCount(pure);
bytes = Tcl_GetStringFromObj(pure, &length);
- /* Handle things like -INT_MIN == INT_MIN */
+ /* Already did the sign above */
if (*bytes == '-') {
length--; bytes++;
}
@@ -2024,8 +2057,9 @@ TclAppendFormattedObjs(interp, appendObj, format, objc, objv)
case 'o':
case 'x':
case 'X': {
- Tcl_WideUInt bits;
- int length, numDigits = 0, base = 16;
+ Tcl_WideUInt bits = (Tcl_WideUInt)0;
+ int length, numBits = 4, numDigits = 0, base = 16;
+ int index = 0, shift = 0;
Tcl_Obj *pure;
char *bytes;
@@ -2034,6 +2068,7 @@ TclAppendFormattedObjs(interp, appendObj, format, objc, objv)
}
if (ch == 'o') {
base = 8;
+ numBits = 3;
}
if (useShort) {
unsigned short int us = (unsigned short int) s;
@@ -2049,6 +2084,14 @@ TclAppendFormattedObjs(interp, appendObj, format, objc, objv)
numDigits++;
uw /= base;
}
+ } else if (useBig) {
+ int leftover = (big.used * DIGIT_BIT) % numBits;
+ mp_digit mask = (~(mp_digit)0) << (DIGIT_BIT-leftover);
+ numDigits = 1 + ((big.used * DIGIT_BIT) / numBits);
+ while ((mask & big.dp[big.used-1]) == 0) {
+ numDigits--;
+ mask >>= numBits;
+ }
} else {
unsigned long int ul = (unsigned long int) l;
bits = (Tcl_WideUInt) ul;
@@ -2066,7 +2109,15 @@ TclAppendFormattedObjs(interp, appendObj, format, objc, objv)
bytes = Tcl_GetString(pure);
length = numDigits;
while (numDigits--) {
- int digitOffset = (int) (bits % base);
+ int digitOffset;
+ if (useBig) {
+ if (shift<CHAR_BIT*sizeof(Tcl_WideUInt)-DIGIT_BIT) {
+ bits |= (((Tcl_WideUInt)big.dp[index++]) << shift);
+ shift += DIGIT_BIT;
+ }
+ shift -= numBits;
+ }
+ digitOffset = (int) (bits % base);
if (digitOffset > 9) {
bytes[numDigits] = 'a' + digitOffset - 10;
} else {
diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c
index b27ab3d..2b87660 100644
--- a/generic/tclStubInit.c
+++ b/generic/tclStubInit.c
@@ -8,7 +8,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclStubInit.c,v 1.122 2005/08/24 17:56:23 andreas_kupries Exp $
+ * RCS: @(#) $Id: tclStubInit.c,v 1.123 2005/10/08 14:42:45 dgp Exp $
*/
#include "tclInt.h"
@@ -128,7 +128,7 @@ TclIntStubs tclIntStubs = {
TclInExit, /* 46 */
NULL, /* 47 */
NULL, /* 48 */
- TclIncrVar2, /* 49 */
+ NULL, /* 49 */
TclInitCompiledLocals, /* 50 */
TclInterpInit, /* 51 */
NULL, /* 52 */
@@ -224,7 +224,7 @@ TclIntStubs tclIntStubs = {
NULL, /* 137 */
TclGetEnv, /* 138 */
NULL, /* 139 */
- TclLooksLikeInt, /* 140 */
+ NULL, /* 140 */
TclpGetCwd, /* 141 */
TclSetByteCodeFromAny, /* 142 */
TclAddLiteralObj, /* 143 */
@@ -258,7 +258,7 @@ TclIntStubs tclIntStubs = {
TclCheckExecutionTraces, /* 171 */
TclInThreadExit, /* 172 */
TclUniCharMatch, /* 173 */
- TclIncrWideVar2, /* 174 */
+ NULL, /* 174 */
TclCallVarTraces, /* 175 */
TclCleanupVar, /* 176 */
TclVarErrMsg, /* 177 */
@@ -982,12 +982,13 @@ TclStubs tclStubs = {
Tcl_DbNewBignumObj, /* 556 */
Tcl_SetBignumObj, /* 557 */
Tcl_GetBignumFromObj, /* 558 */
- Tcl_TruncateChannel, /* 559 */
- Tcl_ChannelTruncateProc, /* 560 */
- Tcl_SetChannelErrorInterp, /* 561 */
- Tcl_GetChannelErrorInterp, /* 562 */
- Tcl_SetChannelError, /* 563 */
- Tcl_GetChannelError, /* 564 */
+ Tcl_GetBignumAndClearObj, /* 559 */
+ Tcl_TruncateChannel, /* 560 */
+ Tcl_ChannelTruncateProc, /* 561 */
+ Tcl_SetChannelErrorInterp, /* 562 */
+ Tcl_GetChannelErrorInterp, /* 563 */
+ Tcl_SetChannelError, /* 564 */
+ Tcl_GetChannelError, /* 565 */
};
/* !END!: Do not edit above this line. */
diff --git a/generic/tclTest.c b/generic/tclTest.c
index 8c0067f..8e09f5e 100644
--- a/generic/tclTest.c
+++ b/generic/tclTest.c
@@ -14,7 +14,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclTest.c,v 1.96 2005/09/08 14:10:55 dkf Exp $
+ * RCS: @(#) $Id: tclTest.c,v 1.97 2005/10/08 14:42:45 dgp Exp $
*/
#define TCL_TEST
@@ -258,6 +258,14 @@ static int TestexithandlerCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int argc, CONST char **argv));
static int TestexprlongCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int argc, CONST char **argv));
+static int TestexprlongobjCmd _ANSI_ARGS_((ClientData dummy,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *CONST objv[]));
+static int TestexprdoubleCmd _ANSI_ARGS_((ClientData dummy,
+ Tcl_Interp *interp, int argc, CONST char **argv));
+static int TestexprdoubleobjCmd _ANSI_ARGS_((ClientData dummy,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *CONST objv[]));
static int TestexprparserObjCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int objc,
Tcl_Obj *CONST objv[]));
@@ -640,6 +648,12 @@ Tcltest_Init(interp)
(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "testexprlong", TestexprlongCmd,
(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
+ Tcl_CreateObjCommand(interp, "testexprlongobj", TestexprlongobjCmd,
+ (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
+ Tcl_CreateCommand(interp, "testexprdouble", TestexprdoubleCmd,
+ (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
+ Tcl_CreateObjCommand(interp, "testexprdoubleobj", TestexprdoubleobjCmd,
+ (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateObjCommand(interp, "testexprparser", TestexprparserObjCmd,
(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "testexprstring", TestexprstringCmd,
@@ -2315,6 +2329,135 @@ TestexprlongCmd(clientData, interp, argc, argv)
/*
*----------------------------------------------------------------------
*
+ * TestexprlongobjCmd --
+ *
+ * This procedure verifies that Tcl_ExprLongObj does not modify the
+ * interpreter result if there is no error.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+TestexprlongobjCmd(clientData, interp, objc, objv)
+ ClientData clientData; /* Not used. */
+ Tcl_Interp *interp; /* Current interpreter. */
+ int objc; /* Number of arguments. */
+ Tcl_Obj *CONST *objv; /* Argument objects. */
+{
+ long exprResult;
+ char buf[4 + TCL_INTEGER_SPACE];
+ int result;
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "expression");
+ return TCL_ERROR;
+ }
+ Tcl_SetResult(interp, "This is a result", TCL_STATIC);
+ result = Tcl_ExprLongObj(interp, objv[1], &exprResult);
+ if (result != TCL_OK) {
+ return result;
+ }
+ sprintf(buf, ": %ld", exprResult);
+ Tcl_AppendResult(interp, buf, NULL);
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TestexprdoubleCmd --
+ *
+ * This procedure verifies that Tcl_ExprDouble does not modify the
+ * interpreter result if there is no error.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+TestexprdoubleCmd(clientData, interp, argc, argv)
+ ClientData clientData; /* Not used. */
+ Tcl_Interp *interp; /* Current interpreter. */
+ int argc; /* Number of arguments. */
+ CONST char **argv; /* Argument strings. */
+{
+ double exprResult;
+ char buf[4 + TCL_DOUBLE_SPACE];
+ int result;
+
+ if (argc != 2) {
+ Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0],
+ " expression\"", (char *) NULL);
+ return TCL_ERROR;
+ }
+ Tcl_SetResult(interp, "This is a result", TCL_STATIC);
+ result = Tcl_ExprDouble(interp, argv[1], &exprResult);
+ if (result != TCL_OK) {
+ return result;
+ }
+ strcpy(buf, ": ");
+ Tcl_PrintDouble(interp, exprResult, buf+2);
+ Tcl_AppendResult(interp, buf, NULL);
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TestexprdoubleobjCmd --
+ *
+ * This procedure verifies that Tcl_ExprLongObj does not modify the
+ * interpreter result if there is no error.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+TestexprdoubleobjCmd(clientData, interp, objc, objv)
+ ClientData clientData; /* Not used. */
+ Tcl_Interp *interp; /* Current interpreter. */
+ int objc; /* Number of arguments. */
+ Tcl_Obj *CONST *objv; /* Argument objects. */
+{
+ double exprResult;
+ char buf[4 + TCL_DOUBLE_SPACE];
+ int result;
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "expression");
+ return TCL_ERROR;
+ }
+ Tcl_SetResult(interp, "This is a result", TCL_STATIC);
+ result = Tcl_ExprDoubleObj(interp, objv[1], &exprResult);
+ if (result != TCL_OK) {
+ return result;
+ }
+ strcpy(buf, ": ");
+ Tcl_PrintDouble(interp, exprResult, buf+2);
+ Tcl_AppendResult(interp, buf, NULL);
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* TestexprstringCmd --
*
* This procedure tests the basic operation of Tcl_ExprString.
diff --git a/generic/tclTestObj.c b/generic/tclTestObj.c
index 1a07b87..51e91cf 100644
--- a/generic/tclTestObj.c
+++ b/generic/tclTestObj.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: tclTestObj.c,v 1.14 2005/06/07 09:18:14 dkf Exp $
+ * RCS: @(#) $Id: tclTestObj.c,v 1.15 2005/10/08 14:42:45 dgp Exp $
*/
#include "tclInt.h"
@@ -45,9 +45,11 @@ static int TestbignumobjCmd _ANSI_ARGS_((ClientData dummy,
static int TestbooleanobjCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int objc,
Tcl_Obj *CONST objv[]));
+#if 0
static int TestconvertobjCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int objc,
Tcl_Obj *CONST objv[]));
+#endif
static int TestdoubleobjCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int objc,
Tcl_Obj *CONST objv[]));
@@ -104,8 +106,10 @@ TclObjTest_Init(interp)
(ClientData) 0, (Tcl_CmdDeleteProc*) NULL );
Tcl_CreateObjCommand(interp, "testbooleanobj", TestbooleanobjCmd,
(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
+#if 0
Tcl_CreateObjCommand(interp, "testconvertobj", TestconvertobjCmd,
(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
+#endif
Tcl_CreateObjCommand(interp, "testdoubleobj", TestdoubleobjCmd,
(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateObjCommand(interp, "testintobj", TestintobjCmd,
@@ -370,6 +374,7 @@ TestbooleanobjCmd(clientData, interp, objc, objv)
return TCL_OK;
}
+#if 0
/*
*----------------------------------------------------------------------
*
@@ -423,6 +428,7 @@ TestconvertobjCmd(clientData, interp, objc, objv)
}
return TCL_OK;
}
+#endif
/*
*----------------------------------------------------------------------
diff --git a/generic/tclThreadTest.c b/generic/tclThreadTest.c
index cca3c5f..50dd8c9 100644
--- a/generic/tclThreadTest.c
+++ b/generic/tclThreadTest.c
@@ -11,11 +11,13 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclThreadTest.c,v 1.21 2005/08/26 22:11:16 andreas_kupries Exp $
+ * RCS: @(#) $Id: tclThreadTest.c,v 1.22 2005/10/08 14:42:45 dgp Exp $
*/
#include "tclInt.h"
+extern int Tcltest_Init( Tcl_Interp* );
+
#ifdef TCL_THREADS
/*
* Each thread has an single instance of the following structure. There
diff --git a/generic/tclTomMath.h b/generic/tclTomMath.h
index 313b6a4..a807e10 100644
--- a/generic/tclTomMath.h
+++ b/generic/tclTomMath.h
@@ -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: tclTomMath.h,v 1.3 2005/09/26 19:31:18 kennykb Exp $
+ * RCS: @(#) $Id: tclTomMath.h,v 1.4 2005/10/08 14:42:45 dgp Exp $
*/
#ifndef TCLTOMMATH_H
@@ -72,10 +72,12 @@ void* TclBNCalloc( size_t, size_t );
#define fast_s_mp_sqr TclBN_fast_s_mp_sqr
#define mp_add TclBN_mp_add
#define mp_add_d TclBN_mp_add_d
+#define mp_and TclBN_mp_and
#define mp_clamp TclBN_mp_clamp
#define mp_clear TclBN_mp_clear
#define mp_clear_multi TclBN_mp_clear_multi
#define mp_cmp TclBN_mp_cmp
+#define mp_cmp_d TclBN_mp_cmp_d
#define mp_cmp_mag TclBN_mp_cmp_mag
#define mp_copy TclBN_mp_copy
#define mp_count_bits TclBN_mp_count_bits
@@ -85,6 +87,7 @@ void* TclBNCalloc( size_t, size_t );
#define mp_div_2d TclBN_mp_div_2d
#define mp_div_3 TclBN_mp_div_3
#define mp_exch TclBN_mp_exch
+#define mp_expt_d TclBN_mp_expt_d
#define mp_grow TclBN_mp_grow
#define mp_init TclBN_mp_init
#define mp_init_copy TclBN_mp_init_copy
@@ -100,16 +103,24 @@ void* TclBNCalloc( size_t, size_t );
#define mp_mul_2 TclBN_mp_mul_2
#define mp_mul_2d TclBN_mp_mul_2d
#define mp_mul_d TclBN_mp_mul_d
+#define mp_neg TclBN_mp_neg
+#define mp_or TclBN_mp_or
#define mp_radix_size TclBN_mp_radix_size
#define mp_read_radix TclBN_mp_read_radix
#define mp_rshd TclBN_mp_rshd
+#define mp_shrink TclBN_mp_shrink
#define mp_set TclBN_mp_set
#define mp_sqr TclBN_mp_sqr
+#define mp_sqrt TclBN_mp_sqrt
#define mp_sub TclBN_mp_sub
#define mp_sub_d TclBN_mp_sub_d
+#define mp_to_unsigned_bin TclBN_mp_to_unsigned_bin
+#define mp_to_unsigned_bin_n TclBN_mp_to_unsigned_bin_n
#define mp_toom_mul TclBN_mp_toom_mul
#define mp_toom_sqr TclBN_mp_toom_sqr
#define mp_toradix_n TclBN_mp_toradix_n
+#define mp_unsigned_bin_size TclBN_mp_unsigned_bin_size
+#define mp_xor TclBN_mp_xor
#define mp_zero TclBN_mp_zero
#define s_mp_add TclBN_s_mp_add
#define s_mp_mul_digs TclBN_s_mp_mul_digs
diff --git a/generic/tclTomMathInterface.c b/generic/tclTomMathInterface.c
index 89537b9..7eda5c3 100644
--- a/generic/tclTomMathInterface.c
+++ b/generic/tclTomMathInterface.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: tclTomMathInterface.c,v 1.2 2005/05/10 18:34:51 kennykb Exp $
+ * RCS: @(#) $Id: tclTomMathInterface.c,v 1.3 2005/10/08 14:42:45 dgp Exp $
*/
#include "tclInt.h"
@@ -141,3 +141,83 @@ TclBNInitBignumFromLong( mp_int* a, long initVal )
a->used = p - a->dp;
}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclBNInitBignumFromWideInt --
+ *
+ * Allocate and initialize a 'bignum' from a Tcl_WideInt
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * The 'bignum' is constructed.
+ *
+ *----------------------------------------------------------------------
+ */
+
+extern void
+TclBNInitBignumFromWideInt(mp_int* a,
+ /* Bignum to initialize */
+ Tcl_WideInt v)
+ /* Initial value */
+{
+ if (v < (Tcl_WideInt)0) {
+ TclBNInitBignumFromWideUInt(a, (Tcl_WideUInt)(-v));
+ mp_neg(a, a);
+ } else {
+ TclBNInitBignumFromWideUInt(a, (Tcl_WideUInt)v);
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclBNInitBignumFromWideUInt --
+ *
+ * Allocate and initialize a 'bignum' from a Tcl_WideUInt
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * The 'bignum' is constructed.
+ *
+ *----------------------------------------------------------------------
+ */
+
+extern void
+TclBNInitBignumFromWideUInt(mp_int* a,
+ /* Bignum to initialize */
+ Tcl_WideUInt v)
+ /* Initial value */
+{
+
+ int status;
+ mp_digit* p;
+
+ /*
+ * Allocate enough memory to hold the largest possible Tcl_WideUInt
+ */
+
+ status = mp_init_size(a, ((CHAR_BIT * sizeof( Tcl_WideUInt )
+ + DIGIT_BIT - 1)
+ / DIGIT_BIT));
+ if (status != MP_OKAY) {
+ Tcl_Panic( "initialization failure in TclBNInitBignumFromWideUInt" );
+ }
+
+ a->sign = MP_ZPOS;
+
+ /* Store the magnitude in the bignum. */
+
+ p = a->dp;
+ while ( v ) {
+ *p++ = (mp_digit) ( v & MP_MASK );
+ v >>= MP_DIGIT_BIT;
+ }
+ a->used = p - a->dp;
+
+}
diff --git a/generic/tclUtil.c b/generic/tclUtil.c
index 1dd6fcb..7e9e35a 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.65 2005/09/15 16:40:02 dgp Exp $
+ * RCS: @(#) $Id: tclUtil.c,v 1.66 2005/10/08 14:42:45 dgp Exp $
*/
#include "tclInt.h"
@@ -19,26 +19,6 @@
#include <math.h>
/*
- * Define test for NaN
- */
-
-#ifdef _MSC_VER
-#define IS_NAN(f) (_isnan((f)))
-#else
-#define IS_NAN(f) ((f) != (f))
-#endif
-
-/*
- * Define test for Inf
- */
-
-#ifdef _MSC_VER
-#define IS_INF(f) ( ! (_finite((f))))
-#else
-#define IS_INF(f) ( (f) > DBL_MAX || (f) < -DBL_MAX )
-#endif
-
-/*
* The absolute pathname of the executable in which this Tcl library
* is running.
*/
@@ -87,6 +67,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));
@@ -1906,7 +1888,7 @@ Tcl_PrintDouble(interp, value, dst)
* Handle NaN.
*/
- if (IS_NAN(value)) {
+ if (TclIsNaN(value)) {
TclFormatNaN(value, dst);
return;
}
@@ -1915,7 +1897,7 @@ Tcl_PrintDouble(interp, value, dst)
* Handle infinities.
*/
- if (IS_INF(value)) {
+ if (TclIsInfinite(value)) {
if (value < 0) {
strcpy(dst, "-Inf");
} else {
@@ -2175,6 +2157,7 @@ TclNeedSpace(start, end)
}
return 1;
}
+#if 0
/*
*----------------------------------------------------------------------
@@ -2228,6 +2211,61 @@ TclLooksLikeInt(bytes, length)
return (0 != TclParseInteger(p, length));
}
+#endif
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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;
+}
/*
*----------------------------------------------------------------------
@@ -2291,7 +2329,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];
diff --git a/generic/tclVar.c b/generic/tclVar.c
index 5e196a7..eddeb42 100644
--- a/generic/tclVar.c
+++ b/generic/tclVar.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: tclVar.c,v 1.109 2005/07/23 00:04:32 dkf Exp $
+ * RCS: @(#) $Id: tclVar.c,v 1.110 2005/10/08 14:42:45 dgp Exp $
*/
#include "tclInt.h"
@@ -1718,6 +1718,7 @@ TclPtrSetVar(interp, varPtr, arrayPtr, part1, part2, newValuePtr, flags)
}
return resultPtr;
}
+#if 0
/*
*----------------------------------------------------------------------
@@ -1881,6 +1882,133 @@ TclPtrIncrVar(interp, varPtr, arrayPtr, part1, part2, incrAmount, flags)
return TclPtrSetVar(interp, varPtr, arrayPtr, part1, part2,
varValuePtr, flags);
}
+#endif
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclIncrObjVar2 --
+ *
+ * Given a two-part variable name, which may refer either to a scalar
+ * variable or an element of an array, increment the Tcl object value of
+ * the variable by a specified Tcl_Obj increment value.
+ *
+ * Results:
+ * Returns a pointer to the Tcl_Obj holding the new value of the
+ * variable. If the specified variable doesn't exist, or there is a
+ * clash in array usage, or an error occurs while executing variable
+ * traces, then NULL is returned and a message will be left in the
+ * interpreter's result.
+ *
+ * Side effects:
+ * The value of the given variable is incremented by the specified
+ * amount. If either the array or the entry didn't exist then a new
+ * variable is created. The ref count for the returned object is _not_
+ * incremented to reflect the returned reference; if you want to keep a
+ * reference to the object you must increment its ref count yourself.
+ *
+ *----------------------------------------------------------------------
+ */
+
+Tcl_Obj *
+TclIncrObjVar2(interp, part1Ptr, part2Ptr, incrPtr, flags)
+ Tcl_Interp *interp; /* Command interpreter in which variable is to
+ * be found. */
+ Tcl_Obj *part1Ptr; /* Points to an object holding the name of an
+ * array (if part2 is non-NULL) or the name of
+ * a variable. */
+ Tcl_Obj *part2Ptr; /* If non-null, points to an object holding
+ * the name of an element in the array
+ * part1Ptr. */
+ Tcl_Obj *incrPtr; /* Amount to be added to variable. */
+ int flags; /* Various flags that tell how to incr value:
+ * any of TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY,
+ * TCL_APPEND_VALUE, TCL_LIST_ELEMENT,
+ * TCL_LEAVE_ERR_MSG. */
+{
+ Var *varPtr, *arrayPtr;
+ char *part1, *part2;
+
+ part1 = TclGetString(part1Ptr);
+ part2 = ((part2Ptr == NULL)? NULL : TclGetString(part2Ptr));
+
+ varPtr = TclObjLookupVar(interp, part1Ptr, part2, flags, "read",
+ 0, 1, &arrayPtr);
+ if (varPtr == NULL) {
+ Tcl_AddObjErrorInfo(interp,
+ "\n (reading value of variable to increment)", -1);
+ return NULL;
+ }
+ return TclPtrIncrObjVar(interp, varPtr, arrayPtr, part1, part2,
+ incrPtr, flags);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclPtrIncrObjVar --
+ *
+ * Given the pointers to a variable and possible containing array,
+ * increment the Tcl object value of the variable by a Tcl_Obj increment.
+ *
+ * Results:
+ * Returns a pointer to the Tcl_Obj holding the new value of the
+ * variable. If the specified variable doesn't exist, or there is a
+ * clash in array usage, or an error occurs while executing variable
+ * traces, then NULL is returned and a message will be left in the
+ * interpreter's result.
+ *
+ * Side effects:
+ * The value of the given variable is incremented by the specified
+ * amount. If either the array or the entry didn't exist then a new
+ * variable is created. The ref count for the returned object is _not_
+ * incremented to reflect the returned reference; if you want to keep a
+ * reference to the object you must increment its ref count yourself.
+ *
+ *----------------------------------------------------------------------
+ */
+
+Tcl_Obj *
+TclPtrIncrObjVar(interp, varPtr, arrayPtr, part1, part2, incrPtr, flags)
+ Tcl_Interp *interp; /* Command interpreter in which variable is to
+ * be found. */
+ Var *varPtr;
+ Var *arrayPtr;
+ CONST char *part1; /* Points to an object holding the name of an
+ * array (if part2 is non-NULL) or the name of
+ * a variable. */
+ CONST char *part2; /* If non-null, points to an object holding
+ * the name of an element in the array
+ * part1Ptr. */
+ Tcl_Obj *incrPtr; /* Increment value */
+/* TODO: Which of these flag values really make sense? */
+ CONST int flags; /* Various flags that tell how to incr value:
+ * any of TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY,
+ * TCL_APPEND_VALUE, TCL_LIST_ELEMENT,
+ * TCL_LEAVE_ERR_MSG. */
+{
+ register Tcl_Obj *varValuePtr, *newValuePtr = NULL;
+ int code;
+
+ varValuePtr = TclPtrGetVar(interp, varPtr, arrayPtr, part1, part2, flags);
+ if (varValuePtr == NULL) {
+ Tcl_AddObjErrorInfo(interp,
+ "\n (reading value of variable to increment)", -1);
+ return NULL;
+ }
+ if (Tcl_IsShared(varValuePtr)) {
+ varValuePtr = Tcl_DuplicateObj(varValuePtr);
+ }
+ code = TclIncrObj(interp, varValuePtr, incrPtr);
+ Tcl_IncrRefCount(varValuePtr);
+ if (code == TCL_OK) {
+ newValuePtr = TclPtrSetVar(interp, varPtr, arrayPtr, part1, part2,
+ varValuePtr, flags);
+ }
+ Tcl_DecrRefCount(varValuePtr);
+ return newValuePtr;
+}
+#if 0
/*
*----------------------------------------------------------------------
@@ -2038,6 +2166,7 @@ TclPtrIncrWideVar(interp, varPtr, arrayPtr, part1, part2, incrAmount, flags)
return TclPtrSetVar(interp, varPtr, arrayPtr, part1, part2,
varValuePtr, flags);
}
+#endif
/*
*----------------------------------------------------------------------
diff --git a/generic/tommath.h b/generic/tommath.h
index 1eabf11..ed2b986 100644
--- a/generic/tommath.h
+++ b/generic/tommath.h
@@ -549,7 +549,7 @@ TOMMATH_STORAGE_CLASS int mp_to_unsigned_bin_n (mp_int * a, unsigned char *b, un
TOMMATH_STORAGE_CLASS int mp_signed_bin_size(mp_int *a);
TOMMATH_STORAGE_CLASS int mp_read_signed_bin(mp_int *a, const unsigned char *b, int c);
-TOMMATH_STORAGE_CLASS int mp_to_signed_bin(mp_int *a, unsigned char *b);
+TOMMATH_STORAGE_CLASS int mp_to_signed_bin(mp_int *a, unsigned char *b);
TOMMATH_STORAGE_CLASS int mp_to_signed_bin_n (mp_int * a, unsigned char *b, unsigned long *outlen);
TOMMATH_STORAGE_CLASS int mp_read_radix(mp_int *a, const char *str, int radix);
@@ -603,6 +603,6 @@ extern const char *mp_s_rmap;
/* $Source: /root/tcl/repos-to-convert/tcl/generic/tommath.h,v $ */
-/* $Revision: 1.3 $ */
-/* $Date: 2005/09/26 18:44:06 $ */
+/* $Revision: 1.4 $ */
+/* $Date: 2005/10/08 14:42:45 $ */
generated by cgit v0.12 at 2024-11-16 08:59:42 (GMT)