summaryrefslogtreecommitdiffstats
path: root/generic
diff options
context:
space:
mode:
authorKevin B Kenny <kennykb@acm.org>2005-05-10 18:33:37 (GMT)
committerKevin B Kenny <kennykb@acm.org>2005-05-10 18:33:37 (GMT)
commit76e3b5eed61a674bce7f9c1e18380842dcff3fbf (patch)
tree2f108341f2c542f48532e6057d79bfa551a4245f /generic
parent5b510b75ec4a1d6fb55691bcf55dbf4b0b936624 (diff)
downloadtcl-76e3b5eed61a674bce7f9c1e18380842dcff3fbf.zip
tcl-76e3b5eed61a674bce7f9c1e18380842dcff3fbf.tar.gz
tcl-76e3b5eed61a674bce7f9c1e18380842dcff3fbf.tar.bz2
Merged kennykb-numerics-branch back to the head; TIPs 132 and 232
Diffstat (limited to 'generic')
-rw-r--r--generic/tcl.decls17
-rw-r--r--generic/tcl.h19
-rw-r--r--generic/tclBasic.c1195
-rw-r--r--generic/tclBinary.c15
-rw-r--r--generic/tclCmdAH.c2
-rw-r--r--generic/tclCmdIL.c2
-rw-r--r--generic/tclCmdMZ.c15
-rw-r--r--generic/tclCompCmds.c2
-rw-r--r--generic/tclCompExpr.c103
-rw-r--r--generic/tclCompile.c2
-rw-r--r--generic/tclCompile.h60
-rw-r--r--generic/tclConfig.c2
-rw-r--r--generic/tclDecls.h45
-rw-r--r--generic/tclDictObj.c2
-rw-r--r--generic/tclEncoding.c2
-rw-r--r--generic/tclEnv.c2
-rw-r--r--generic/tclEvent.c8
-rw-r--r--generic/tclExecute.c897
-rw-r--r--generic/tclFCmd.c2
-rw-r--r--generic/tclFileName.c2
-rw-r--r--generic/tclGet.c2
-rw-r--r--generic/tclGetDate.y2
-rw-r--r--generic/tclIO.c2
-rw-r--r--generic/tclIOCmd.c2
-rw-r--r--generic/tclIOUtil.c2
-rw-r--r--generic/tclInt.decls19
-rw-r--r--generic/tclInt.h25
-rw-r--r--generic/tclIntDecls.h55
-rw-r--r--generic/tclInterp.c2
-rw-r--r--generic/tclListObj.c2
-rw-r--r--generic/tclLiteral.c2
-rw-r--r--generic/tclNamesp.c2
-rw-r--r--generic/tclNotify.c2
-rw-r--r--generic/tclObj.c468
-rw-r--r--generic/tclParse.c2
-rw-r--r--generic/tclParseExpr.c69
-rw-r--r--generic/tclPathObj.c2
-rw-r--r--generic/tclPort.h2
-rw-r--r--generic/tclProc.c2
-rw-r--r--generic/tclRegexp.c2
-rw-r--r--generic/tclResult.c2
-rw-r--r--generic/tclScan.c4
-rwxr-xr-xgeneric/tclStrToD.c1361
-rw-r--r--generic/tclStringObj.c2
-rw-r--r--generic/tclStubInit.c11
-rw-r--r--generic/tclTest.c2
-rw-r--r--generic/tclTestObj.c172
-rw-r--r--generic/tclThread.c2
-rwxr-xr-xgeneric/tclThreadAlloc.c2
-rw-r--r--generic/tclThreadTest.c2
-rw-r--r--generic/tclTimer.c2
-rw-r--r--generic/tclTomMath.h109
-rw-r--r--generic/tclTomMathInterface.c143
-rw-r--r--generic/tclTrace.c2
-rw-r--r--generic/tclUtf.c2
-rw-r--r--generic/tclUtil.c188
-rw-r--r--generic/tclVar.c2
-rw-r--r--generic/tommath.h591
58 files changed, 4381 insertions, 1278 deletions
diff --git a/generic/tcl.decls b/generic/tcl.decls
index 4ad45ab..82219aa 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.110 2005/05/03 18:07:44 dgp Exp $
+# RCS: @(#) $Id: tcl.decls,v 1.111 2005/05/10 18:34:04 kennykb Exp $
library tcl
@@ -1989,6 +1989,21 @@ declare 554 generic {
Tcl_DriverThreadActionProc *Tcl_ChannelThreadActionProc(Tcl_ChannelType *chanTypePtr)
}
+# TIP #237:
+
+declare 555 generic {
+ Tcl_Obj* Tcl_NewBignumObj( mp_int* value )
+}
+declare 556 generic {
+ Tcl_Obj* Tcl_DbNewBignumObj( mp_int* value, CONST char* file, int line )
+}
+declare 557 generic {
+ void Tcl_SetBignumObj( Tcl_Obj* obj, mp_int* value )
+}
+declare 558 generic {
+ int Tcl_GetBignumFromObj( Tcl_Interp* interp, Tcl_Obj* obj, mp_int* value )
+}
+
##############################################################################
# Define the platform specific public Tcl interface. These functions are
diff --git a/generic/tcl.h b/generic/tcl.h
index 97e6d25..bdb8e10 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.197 2005/03/10 22:10:38 dgp Exp $
+ * RCS: @(#) $Id: tcl.h,v 1.198 2005/05/10 18:34:05 kennykb Exp $
*/
#ifndef _TCL
@@ -768,6 +768,12 @@ typedef struct Tcl_Obj {
VOID *ptr1;
VOID *ptr2;
} 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 single word */
+ } bignumValue;
} internalRep;
} Tcl_Obj;
@@ -809,6 +815,8 @@ int Tcl_IsShared _ANSI_ARGS_((Tcl_Obj *objPtr));
*/
#ifdef TCL_MEM_DEBUG
+# define Tcl_NewBignumObj(val) \
+ Tcl_DbNewBignumObj(val, __FILE__, __LINE__)
# define Tcl_NewBooleanObj(val) \
Tcl_DbNewBooleanObj(val, __FILE__, __LINE__)
# define Tcl_NewByteArrayObj(bytes, len) \
@@ -2292,6 +2300,15 @@ typedef void (Tcl_LimitHandlerProc) _ANSI_ARGS_((ClientData clientData,
typedef void (Tcl_LimitHandlerDeleteProc) _ANSI_ARGS_((ClientData clientData));
+#ifndef MP_INT_DECLARED
+typedef struct mp_int mp_int;
+#define MP_INT_DECLARED
+#endif
+#ifndef MP_DIGIT_DECLARED
+typedef unsigned long mp_digit;
+#define MP_DIGIT_DECLARED
+#endif
+
#ifndef TCL_NO_DEPRECATED
/*
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index 9783367..2ec1776 100644
--- a/generic/tclBasic.c
+++ b/generic/tclBasic.c
@@ -13,11 +13,27 @@
* 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.150 2005/05/05 18:37:55 dgp Exp $
+ * RCS: @(#) $Id: tclBasic.c,v 1.151 2005/05/10 18:34:06 kennykb Exp $
*/
#include "tclInt.h"
#include "tclCompile.h"
+#include <float.h>
+#ifndef TCL_NO_MATH
+#include <math.h>
+#endif
+
+/*
+ * The following structure defines the client data for a math function
+ * registered with Tcl_CreateMathFunc
+ */
+
+typedef struct OldMathFuncData {
+ Tcl_MathProc* proc; /* Handler procedure */
+ int numArgs; /* Number of args expected */
+ Tcl_ValueType* argTypes; /* Types of the args */
+ ClientData clientData; /* Client data for the handler function */
+} OldMathFuncData;
/*
* Static procedures in this file:
@@ -30,6 +46,106 @@ static void DeleteInterpProc _ANSI_ARGS_((Tcl_Interp *interp));
static void ProcessUnexpectedResult _ANSI_ARGS_((
Tcl_Interp *interp, int returnCode));
+static int OldMathFuncProc _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp* interp,
+ int argc,
+ Tcl_Obj *CONST *objv ));
+
+static void OldMathFuncDeleteProc _ANSI_ARGS_((ClientData));
+
+static int ExprAbsFunc _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp,
+ int argc,
+ Tcl_Obj *CONST *objv));
+static int ExprBinaryFunc _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp,
+ int argc,
+ Tcl_Obj *CONST *objv));
+static int ExprDoubleFunc _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp,
+ int argc,
+ Tcl_Obj *CONST *objv));
+static int ExprIntFunc _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp,
+ int argc,
+ Tcl_Obj *CONST *objv));
+static int ExprRandFunc _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp,
+ int argc,
+ Tcl_Obj *CONST *objv));
+static int ExprRoundFunc _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp,
+ int argc,
+ Tcl_Obj *CONST *objv));
+static int ExprSrandFunc _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp,
+ int argc,
+ Tcl_Obj *CONST *objv));
+static int ExprUnaryFunc _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp,
+ int argc,
+ Tcl_Obj *CONST *objv));
+static int ExprWideFunc _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp,
+ int argc,
+ Tcl_Obj *CONST *objv));
+static int VerifyExprObjType _ANSI_ARGS_((Tcl_Interp *interp,
+ Tcl_Obj *objPtr));
+
+static void MathFuncWrongNumArgs
+ _ANSI_ARGS_((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;
/*
@@ -144,6 +260,55 @@ static CmdInfo builtInCmds[] = {
{NULL, (Tcl_ObjCmdProc *) NULL, (CompileProc *) NULL, 0}
};
+/*
+ * Math functions
+ */
+
+typedef struct {
+ CONST char* name; /* Name of the function */
+ Tcl_ObjCmdProc* objCmdProc; /* Procedure that evaluates the function */
+ ClientData clientData; /* Client data for the procedure */
+} BuiltinFuncDef;
+BuiltinFuncDef BuiltinFuncTable[] = {
+ { "::tcl::mathfunc::abs", ExprAbsFunc, NULL },
+#ifndef TCL_NO_MATH
+ { "::tcl::mathfunc::acos", ExprUnaryFunc, (ClientData) acos },
+ { "::tcl::mathfunc::asin", ExprUnaryFunc, (ClientData) asin },
+ { "::tcl::mathfunc::atan", ExprUnaryFunc, (ClientData) atan },
+ { "::tcl::mathfunc::atan2", ExprBinaryFunc, (ClientData) atan2 },
+ { "::tcl::mathfunc::ceil", ExprUnaryFunc, (ClientData) ceil },
+ { "::tcl::mathfunc::cos", ExprUnaryFunc, (ClientData) cos },
+ { "::tcl::mathfunc::cosh", ExprUnaryFunc, (ClientData) cosh },
+#endif
+ { "::tcl::mathfunc::double",ExprDoubleFunc, NULL },
+#ifndef TCL_NO_MATH
+ { "::tcl::mathfunc::exp", ExprUnaryFunc, (ClientData) exp },
+ { "::tcl::mathfunc::floor", ExprUnaryFunc, (ClientData) floor },
+ { "::tcl::mathfunc::fmod", ExprBinaryFunc, (ClientData) fmod },
+ { "::tcl::mathfunc::hypot", ExprBinaryFunc, (ClientData) hypot },
+#endif
+ { "::tcl::mathfunc::int", ExprIntFunc, NULL },
+#ifndef TCL_NO_MATH
+ { "::tcl::mathfunc::log", ExprUnaryFunc, (ClientData) log },
+ { "::tcl::mathfunc::log10", ExprUnaryFunc, (ClientData) log10 },
+ { "::tcl::mathfunc::pow", ExprBinaryFunc, (ClientData) pow },
+#endif
+ { "::tcl::mathfunc::rand", ExprRandFunc, NULL },
+ { "::tcl::mathfunc::round", ExprRoundFunc, NULL },
+#ifndef TCL_NO_MATH
+ { "::tcl::mathfunc::sin", ExprUnaryFunc, (ClientData) sin },
+ { "::tcl::mathfunc::sinh", ExprUnaryFunc, (ClientData) sinh },
+ { "::tcl::mathfunc::sqrt", ExprUnaryFunc, (ClientData) sqrt },
+#endif
+ { "::tcl::mathfunc::srand", ExprSrandFunc, NULL },
+#ifndef TCL_NO_MATH
+ { "::tcl::mathfunc::tan", ExprUnaryFunc, (ClientData) tan },
+ { "::tcl::mathfunc::tanh", ExprUnaryFunc, (ClientData) tanh },
+#endif
+ { "::tcl::mathfunc::wide", ExprWideFunc, NULL },
+ { NULL, NULL, NULL }
+};
+
/*
*----------------------------------------------------------------------
@@ -170,10 +335,9 @@ Tcl_CreateInterp()
Interp *iPtr;
Tcl_Interp *interp;
Command *cmdPtr;
- BuiltinFunc *builtinFuncPtr;
- MathFunc *mathFuncPtr;
- Tcl_HashEntry *hPtr;
+ BuiltinFuncDef *builtinFuncPtr;
const CmdInfo *cmdInfoPtr;
+ Tcl_Namespace* mathfuncNSPtr;
int i;
union {
char c[sizeof(short)];
@@ -213,7 +377,6 @@ Tcl_CreateInterp()
iPtr->globalNsPtr = NULL;
iPtr->hiddenCmdTablePtr = NULL;
iPtr->interpInfo = NULL;
- Tcl_InitHashTable(&iPtr->mathFuncTable, TCL_STRING_KEYS);
iPtr->numLevels = 0;
iPtr->maxNestingDepth = MAX_NESTING_DEPTH;
@@ -223,10 +386,10 @@ Tcl_CreateInterp()
iPtr->returnOpts = NULL;
iPtr->errorInfo = NULL;
- iPtr->eiVar = Tcl_NewStringObj("errorInfo", -1);
+ iPtr->eiVar = Tcl_NewStringObj( "errorInfo", -1 );
Tcl_IncrRefCount(iPtr->eiVar);
iPtr->errorCode = NULL;
- iPtr->ecVar = Tcl_NewStringObj("errorCode", -1);
+ iPtr->ecVar = Tcl_NewStringObj( "errorCode", -1 );
Tcl_IncrRefCount(iPtr->ecVar);
iPtr->returnLevel = 0;
iPtr->returnCode = TCL_OK;
@@ -399,6 +562,11 @@ Tcl_CreateInterp()
TclClockOldscanObjCmd, (ClientData) NULL,
(Tcl_CmdDeleteProc*) NULL );
+ /*
+ * Register the built-in functions
+ */
+
+
/* Register the default [interp bgerror] handler. */
Tcl_CreateObjCommand( interp, "::tcl::Bgerror",
@@ -413,21 +581,25 @@ Tcl_CreateInterp()
* Register the builtin math functions.
*/
+ mathfuncNSPtr = Tcl_CreateNamespace( interp, "::tcl::mathfunc",
+ (ClientData) NULL,
+ (Tcl_NamespaceDeleteProc*) NULL );
+ if ( mathfuncNSPtr == NULL ) {
+ Tcl_Panic( "Can't create math function namespace" );
+ }
i = 0;
- for (builtinFuncPtr = tclBuiltinFuncTable; builtinFuncPtr->name != NULL;
- builtinFuncPtr++) {
- Tcl_CreateMathFunc((Tcl_Interp *) iPtr, builtinFuncPtr->name,
- builtinFuncPtr->numArgs, builtinFuncPtr->argTypes,
- (Tcl_MathProc *) NULL, (ClientData) 0);
- hPtr = Tcl_FindHashEntry(&iPtr->mathFuncTable,
- builtinFuncPtr->name);
- if (hPtr == NULL) {
- Tcl_Panic("Tcl_CreateInterp: Tcl_CreateMathFunc incorrectly registered '%s'", builtinFuncPtr->name);
- return NULL;
+ for ( ; ; ) {
+ CONST char* tail;
+ builtinFuncPtr = &(BuiltinFuncTable[ i++ ]);
+ if ( builtinFuncPtr->name == NULL ) {
+ break;
}
- mathFuncPtr = (MathFunc *) Tcl_GetHashValue(hPtr);
- mathFuncPtr->builtinFuncIndex = i;
- i++;
+ Tcl_CreateObjCommand( interp, builtinFuncPtr->name,
+ builtinFuncPtr->objCmdProc,
+ builtinFuncPtr->clientData,
+ (Tcl_CmdDeleteProc*) NULL );
+ tail = builtinFuncPtr->name + strlen( "::tcl::mathfunc::" );
+ Tcl_Export( interp, mathfuncNSPtr, tail, 0 );
}
/*
@@ -936,16 +1108,6 @@ DeleteInterpProc(interp)
Tcl_DeleteHashTable(hTablePtr);
ckfree((char *) hTablePtr);
}
- /*
- * Tear down the math function table.
- */
-
- for (hPtr = Tcl_FirstHashEntry(&iPtr->mathFuncTable, &search);
- hPtr != NULL;
- hPtr = Tcl_NextHashEntry(&search)) {
- ckfree((char *) Tcl_GetHashValue(hPtr));
- }
- Tcl_DeleteHashTable(&iPtr->mathFuncTable);
/*
* Invoke deletion callbacks; note that a callback can create new
@@ -2675,52 +2837,176 @@ Tcl_CreateMathFunc(interp, name, numArgs, argTypes, proc, clientData)
ClientData clientData; /* Additional value to pass to the
* function. */
{
- Interp *iPtr = (Interp *) interp;
- Tcl_HashEntry *hPtr;
- MathFunc *mathFuncPtr;
- int new, i;
- hPtr = Tcl_CreateHashEntry(&iPtr->mathFuncTable, name, &new);
- if (new) {
- Tcl_SetHashValue(hPtr, ckalloc(sizeof(MathFunc)));
+ Tcl_DString bigName;
+
+ OldMathFuncData* data
+ = (OldMathFuncData*) Tcl_Alloc( sizeof ( OldMathFuncData ) );
+
+ if ( numArgs > MAX_MATH_ARGS ) {
+ Tcl_Panic( "attempt to create a math function with too many args" );
}
- mathFuncPtr = (MathFunc *) Tcl_GetHashValue(hPtr);
- if (!new) {
- if (mathFuncPtr->builtinFuncIndex >= 0) {
- /*
- * We are redefining a builtin math function. Invalidate the
- * interpreter's existing code by incrementing its
- * compileEpoch member. This field is checked in Tcl_EvalObj
- * and ObjInterpProc, and code whose compilation epoch doesn't
- * match is recompiled. Newly compiled code will no longer
- * treat the function as builtin.
- */
+ data->proc = proc;
+ data->numArgs = numArgs;
+ data->argTypes
+ = (Tcl_ValueType*) Tcl_Alloc( numArgs * sizeof( Tcl_ValueType ) );
+ memcpy( data->argTypes, argTypes, numArgs * sizeof( Tcl_ValueType ) );
+ data->clientData = clientData;
- iPtr->compileEpoch++;
- } else {
- /*
- * A non-builtin function is being redefined. We must invalidate
- * existing code if the number of arguments has changed. This
- * is because existing code was compiled assuming that number.
- */
+ Tcl_DStringInit( &bigName );
+ Tcl_DStringAppend( &bigName, "::tcl::mathfunc::", -1 );
+ Tcl_DStringAppend( &bigName, name, -1 );
- if (numArgs != mathFuncPtr->numArgs) {
- iPtr->compileEpoch++;
+ Tcl_CreateObjCommand( interp, Tcl_DStringValue( &bigName ),
+ OldMathFuncProc, (ClientData) data,
+ OldMathFuncDeleteProc );
+ Tcl_DStringFree( &bigName );
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * OldMathFuncProc --
+ *
+ * Dispatch to a math function created with Tcl_CreateMathFunc
+ *
+ * Results:
+ * Returns a standard Tcl result.
+ *
+ * Side effects:
+ * Whatever the math function does.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+OldMathFuncProc( clientData, interp, objc, objv )
+ ClientData clientData; /* Ponter to OldMathFuncData describing
+ * the function being called */
+ Tcl_Interp* interp; /* Tcl interpreter */
+ int objc; /* Actual parameter count */
+ Tcl_Obj *CONST *objv; /* Parameter vector */
+{
+ Tcl_Obj* valuePtr;
+ OldMathFuncData* dataPtr = (OldMathFuncData*) clientData;
+ Tcl_Value args[MAX_MATH_ARGS];
+ Tcl_Value funcResult;
+ int result;
+ int i, j, k;
+ double d;
+
+ /* Check argument count */
+
+ if ( objc != dataPtr->numArgs + 1 ) {
+ MathFuncWrongNumArgs( interp, dataPtr->numArgs+1, objc, objv );
+ return TCL_ERROR;
+ }
+
+ /* Convert arguments from Tcl_Obj's to Tcl_Value's */
+
+ for ( j = 1, k = 0; j < objc; ++j, ++k ) {
+ valuePtr = objv[j];
+ if (VerifyExprObjType(interp, valuePtr) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ /*
+ * Copy the object's numeric value to the argument record,
+ * converting it if necessary.
+ */
+
+ if (valuePtr->typePtr == &tclIntType) {
+ i = valuePtr->internalRep.longValue;
+ if (dataPtr->argTypes[k] == TCL_DOUBLE) {
+ args[k].type = TCL_DOUBLE;
+ args[k].doubleValue = i;
+ } else if (dataPtr->argTypes[k] == TCL_WIDE_INT) {
+ args[k].type = TCL_WIDE_INT;
+ args[k].wideValue = Tcl_LongAsWide(i);
+ } else {
+ args[k].type = TCL_INT;
+ args[k].intValue = i;
+ }
+ } else if (valuePtr->typePtr == &tclWideIntType) {
+ Tcl_WideInt w;
+ TclGetWide(w,valuePtr);
+ if (dataPtr->argTypes[k] == TCL_DOUBLE) {
+ args[k].type = TCL_DOUBLE;
+ args[k].doubleValue = Tcl_WideAsDouble(w);
+ } else if (dataPtr->argTypes[k] == TCL_INT) {
+ args[k].type = TCL_INT;
+ args[k].intValue = Tcl_WideAsLong(w);
+ } else {
+ args[k].type = TCL_WIDE_INT;
+ args[k].wideValue = w;
+ }
+ } else {
+ d = valuePtr->internalRep.doubleValue;
+ if (dataPtr->argTypes[k] == TCL_INT) {
+ args[k].type = TCL_INT;
+ args[k].intValue = (long) d;
+ } else if (dataPtr->argTypes[k] == TCL_WIDE_INT) {
+ args[k].type = TCL_WIDE_INT;
+ args[k].wideValue = Tcl_DoubleAsWide(d);
+ } else {
+ args[k].type = TCL_DOUBLE;
+ args[k].doubleValue = d;
}
}
}
-
- mathFuncPtr->builtinFuncIndex = -1; /* can't be a builtin function */
- if (numArgs > MAX_MATH_ARGS) {
- numArgs = MAX_MATH_ARGS;
+
+ /* Call the function */
+
+ result = (*dataPtr->proc)(dataPtr->clientData, interp, args,
+ &funcResult);
+ if (result != TCL_OK) {
+ return result;
}
- mathFuncPtr->numArgs = numArgs;
- for (i = 0; i < numArgs; i++) {
- mathFuncPtr->argTypes[i] = argTypes[i];
+
+ /* Return the result of the call */
+
+ if (funcResult.type == TCL_INT) {
+ TclNewLongObj(valuePtr, funcResult.intValue);
+ } else if (funcResult.type == TCL_WIDE_INT) {
+ TclNewWideIntObj(valuePtr, funcResult.wideValue);
+ } else {
+ d = funcResult.doubleValue;
+ if (IS_NAN(d) || IS_INF(d)) {
+ TclExprFloatError(interp, d);
+ return TCL_ERROR;
+ }
+ TclNewDoubleObj(valuePtr, d);
}
- mathFuncPtr->proc = proc;
- mathFuncPtr->clientData = clientData;
+ Tcl_SetObjResult( interp, valuePtr );
+ return TCL_OK;
+
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * OldMathFuncDeleteProc --
+ *
+ * Cleans up after deleting a math function registered with
+ * Tcl_CreateMathFunc
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Frees allocated memory.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+OldMathFuncDeleteProc( clientData )
+ ClientData clientData;
+{
+ OldMathFuncData* dataPtr = (OldMathFuncData*) clientData;
+ Tcl_Free( (VOID*) dataPtr->argTypes );
+ Tcl_Free( (VOID*) dataPtr );
}
/*
@@ -2757,39 +3043,51 @@ Tcl_GetMathFuncInfo(interp, name, numArgsPtr, argTypesPtr, procPtr,
Tcl_MathProc **procPtr;
ClientData *clientDataPtr;
{
- Interp *iPtr = (Interp *) interp;
- Tcl_HashEntry *hPtr;
- MathFunc *mathFuncPtr;
- Tcl_ValueType *argTypes;
- int i,numArgs;
- hPtr = Tcl_FindHashEntry(&iPtr->mathFuncTable, name);
- if (hPtr == NULL) {
- Tcl_AppendResult(interp, "math function \"", name,
- "\" not known in this interpreter", (char *) NULL);
- return TCL_ERROR;
- }
- mathFuncPtr = (MathFunc *) Tcl_GetHashValue(hPtr);
+ Tcl_Obj* cmdNameObj;
+ Command* cmdPtr;
- *numArgsPtr = numArgs = mathFuncPtr->numArgs;
- if (numArgs == 0) {
- /* Avoid doing zero-sized allocs... */
- numArgs = 1;
- }
- *argTypesPtr = argTypes =
- (Tcl_ValueType *)ckalloc(numArgs * sizeof(Tcl_ValueType));
- for (i = 0; i < mathFuncPtr->numArgs; i++) {
- argTypes[i] = mathFuncPtr->argTypes[i];
+ /* Get the command that implements the math function */
+
+ cmdNameObj = Tcl_NewStringObj( "tcl::mathfunc::", -1 );
+ Tcl_AppendToObj( cmdNameObj, name, -1 );
+ Tcl_IncrRefCount( cmdNameObj );
+ cmdPtr = (Command*) Tcl_GetCommandFromObj( interp, cmdNameObj );
+ Tcl_DecrRefCount( cmdNameObj );
+
+ /* Report unknown functions */
+
+ if ( cmdPtr == NULL ) {
+ Tcl_Obj* message;
+ message = Tcl_NewStringObj( "unknown math function \"", -1 );
+ Tcl_AppendToObj( message, name, -1 );
+ Tcl_AppendToObj( message, "\"", 1 );
+ *numArgsPtr = -1; *argTypesPtr = NULL;
+ *procPtr = NULL;
+ *clientDataPtr = NULL;
+ return TCL_ERROR;
}
+
+ /*
+ * Retrieve function info for user defined functions; return
+ * dummy information for builtins.
+ */
- if (mathFuncPtr->builtinFuncIndex == -1) {
- *procPtr = (Tcl_MathProc *) NULL;
+ if ( cmdPtr->objProc == &OldMathFuncProc ) {
+ OldMathFuncData* dataPtr = (OldMathFuncData*) cmdPtr->clientData;
+ *procPtr = dataPtr->proc;
+ *numArgsPtr = dataPtr->numArgs;
+ *argTypesPtr = dataPtr->argTypes;
+ *clientDataPtr = dataPtr->clientData;
} else {
- *procPtr = mathFuncPtr->proc;
- *clientDataPtr = mathFuncPtr->clientData;
+ *procPtr = NULL;
+ *numArgsPtr = -1;
+ *argTypesPtr = NULL;
+ *procPtr = NULL;
+ *clientDataPtr = NULL;
}
-
return TCL_OK;
+
}
/*
@@ -2816,33 +3114,42 @@ Tcl_ListMathFuncs(interp, pattern)
Tcl_Interp *interp;
CONST char *pattern;
{
- Interp *iPtr = (Interp *) interp;
- Tcl_Obj *resultList = Tcl_NewObj();
- register Tcl_HashEntry *hPtr;
- Tcl_HashSearch hSearch;
- CONST char *name;
-
- if ((pattern != NULL) && TclMatchIsTrivial(pattern)) {
- if ((Tcl_FindHashEntry(&iPtr->mathFuncTable, pattern) != NULL)
- && (Tcl_ListObjAppendElement(interp, resultList,
- Tcl_NewStringObj(pattern,-1)) != TCL_OK)) {
- goto error;
- }
- return resultList;
- }
- for (hPtr = Tcl_FirstHashEntry(&iPtr->mathFuncTable, &hSearch);
- hPtr != NULL; hPtr = Tcl_NextHashEntry(&hSearch)) {
- name = Tcl_GetHashKey(&iPtr->mathFuncTable, hPtr);
- if ((pattern == NULL || Tcl_StringMatch(name, pattern)) &&
- /* I don't expect this to fail, but... */
- Tcl_ListObjAppendElement(interp, resultList,
- Tcl_NewStringObj(name,-1)) != TCL_OK) {
-error:
- Tcl_DecrRefCount(resultList);
- return NULL;
+ Namespace* globalNsPtr = (Namespace*) Tcl_GetGlobalNamespace( interp );
+ Namespace* nsPtr;
+ Namespace* dummy1NsPtr;
+ Namespace* dummy2NsPtr;
+ CONST char* dummyNamePtr;
+ Tcl_Obj* result = Tcl_NewObj();
+ Tcl_HashEntry* cmdHashEntry;
+ Tcl_HashSearch cmdHashSearch;
+ CONST char* cmdNamePtr;
+
+ TclGetNamespaceForQualName( interp, "::tcl::mathfunc",
+ globalNsPtr,
+ TCL_FIND_ONLY_NS | TCL_GLOBAL_ONLY,
+ &nsPtr, &dummy1NsPtr, &dummy2NsPtr,
+ &dummyNamePtr );
+
+ if ( nsPtr != NULL ) {
+ if ((pattern != NULL) && TclMatchIsTrivial(pattern)) {
+ if (Tcl_FindHashEntry(&nsPtr->cmdTable, pattern) != NULL) {
+ Tcl_ListObjAppendElement(NULL, result,
+ Tcl_NewStringObj(pattern,-1));
+ }
+ } else {
+ for ( cmdHashEntry =
+ Tcl_FirstHashEntry( &nsPtr->cmdTable, &cmdHashSearch );
+ cmdHashEntry != NULL;
+ cmdHashEntry = Tcl_NextHashEntry( &cmdHashSearch ) ) {
+ cmdNamePtr = Tcl_GetHashKey( &nsPtr->cmdTable, cmdHashEntry );
+ if (pattern == NULL || Tcl_StringMatch(cmdNamePtr, pattern)) {
+ Tcl_ListObjAppendElement( NULL, result,
+ Tcl_NewStringObj( cmdNamePtr, -1 ) );
+ }
+ }
}
}
- return resultList;
+ return result;
}
/*
@@ -3000,7 +3307,7 @@ TclEvalObjvInternal(interp, objc, objv, command, length, flags)
for (i = objc-1; i >= 0; i--) {
newObjv[i+1] = objv[i];
}
- newObjv[0] = Tcl_NewStringObj("::unknown", -1);
+ newObjv[0] = Tcl_NewStringObj( "::unknown", -1);
Tcl_IncrRefCount(newObjv[0]);
cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, newObjv[0]);
if (cmdPtr == NULL) {
@@ -3483,9 +3790,10 @@ Tcl_EvalEx(interp, script, numBytes, flags)
objv[objectsUsed], &numElements);
if (code == TCL_ERROR) {
/* Attempt to expand a non-list */
- Tcl_Obj *msg =
- Tcl_NewStringObj("\n (expanding word ", -1);
- Tcl_Obj *wordNum = Tcl_NewIntObj(objectsUsed);
+ Tcl_Obj *msg;
+ Tcl_Obj *wordNum;
+ msg = Tcl_NewStringObj("\n (expanding word ", -1);
+ TclNewIntObj( wordNum, objectsUsed );
Tcl_IncrRefCount(wordNum);
Tcl_IncrRefCount(msg);
Tcl_AppendObjToObj(msg, wordNum);
@@ -4299,8 +4607,9 @@ TclObjInvoke(interp, objc, objv, flags)
&& ((iPtr->flags & ERR_ALREADY_LOGGED) == 0)) {
int length;
Tcl_Obj *command = Tcl_NewListObj(objc, objv);
- CONST char* cmdString = Tcl_GetStringFromObj(command, &length);
-
+ CONST char* cmdString;
+ Tcl_IncrRefCount( command );
+ cmdString = Tcl_GetStringFromObj(command, &length);
Tcl_LogCommandInfo(interp, cmdString, cmdString, length);
Tcl_DecrRefCount(command);
iPtr->flags &= ~ERR_ALREADY_LOGGED;
@@ -4701,4 +5010,642 @@ Tcl_GetVersion(majorV, minorV, patchLevelV, type)
*type = TCL_RELEASE_LEVEL;
}
}
-
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Math Functions --
+ *
+ * This page contains the procedures that implement all of the
+ * built-in math functions for expressions.
+ *
+ * Results:
+ * Each procedure returns TCL_OK if it succeeds and pushes an
+ * Tcl object holding the result. If it fails it returns TCL_ERROR
+ * and leaves an error message in the interpreter's result.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+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 */
+{
+ double d, dResult;
+ Tcl_Obj* oResult;
+
+ double (*func) _ANSI_ARGS_((double)) =
+ (double (*)_ANSI_ARGS_((double))) clientData;
+
+ /*
+ * Convert the function's argument to a double if necessary.
+ */
+
+ if ( objc != 2 ) {
+ MathFuncWrongNumArgs( interp, 2, objc, objv );
+ } else if ( Tcl_GetDoubleFromObj( interp, objv[1], &d ) == TCL_OK ) {
+
+ /* Evaluate the function */
+
+ 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 );
+ return TCL_OK;
+ }
+
+ return TCL_ERROR;
+}
+
+static int
+ExprBinaryFunc( clientData, interp, objc, objv )
+ ClientData clientData; /* Contains the address of a procedure that
+ * takes two double arguments 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; /* Parameter vector */
+{
+ double d1, d2, dResult;
+ Tcl_Obj* oResult;
+
+ double (*func) _ANSI_ARGS_((double, double))
+ = (double (*)_ANSI_ARGS_((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;
+
+}
+
+static int
+ExprAbsFunc( 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; /* Parameter vector */
+{
+ register Tcl_Obj *valuePtr;
+ long i, iResult;
+ double d, dResult;
+ Tcl_Obj* oResult;
+
+ if ( objc != 2 ) {
+ MathFuncWrongNumArgs( interp, 2, objc, objv );
+ return TCL_ERROR;
+ }
+ valuePtr = objv[1];
+
+ if (VerifyExprObjType(interp, valuePtr) != 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) {
+ /* FIXME: This should promote to wide! */
+ 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 {
+ iResult = i;
+ }
+ TclNewLongObj( oResult, iResult );
+ Tcl_SetObjResult( interp, oResult );
+ } else if (valuePtr->typePtr == &tclWideIntType) {
+ Tcl_WideInt wResult, w;
+ TclGetWide(w,valuePtr);
+ 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;
+ }
+ } else {
+ wResult = w;
+ }
+ TclNewWideIntObj( oResult, wResult );
+ Tcl_SetObjResult( interp, oResult );
+ } else {
+ d = valuePtr->internalRep.doubleValue;
+ if (d < 0.0) {
+ dResult = -d;
+ } else {
+ dResult = d;
+ }
+ if (IS_NAN(dResult)) {
+ TclExprFloatError(interp, dResult);
+ return TCL_ERROR;
+ }
+ TclNewDoubleObj( oResult, dResult );
+ Tcl_SetObjResult( interp, oResult );
+ }
+
+ return TCL_OK;
+}
+
+static int
+ExprDoubleFunc(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 */
+{
+ Tcl_Obj* valuePtr;
+ double dResult;
+ Tcl_Obj* oResult;
+
+ /*
+ * Check parameter type
+ */
+
+ if ( objc != 2 ) {
+ MathFuncWrongNumArgs( interp, 2, objc, objv );
+ } else {
+ valuePtr = objv[1];
+ if ( VerifyExprObjType( interp, valuePtr ) == TCL_OK ) {
+ GET_DOUBLE_VALUE( dResult, valuePtr, valuePtr->typePtr );
+ TclNewDoubleObj( oResult, dResult );
+ Tcl_SetObjResult( interp, oResult );
+ return TCL_OK;
+ }
+ }
+
+ return TCL_ERROR;
+}
+
+static int
+ExprIntFunc(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 */
+{
+
+ register Tcl_Obj *valuePtr;
+ long iResult;
+ double d;
+ Tcl_Obj* oResult;
+
+ if ( objc != 2 ) {
+ MathFuncWrongNumArgs( interp, 2, objc, objv );
+ } else {
+ valuePtr = objv[1];
+ if (VerifyExprObjType(interp, valuePtr) == TCL_OK) {
+ if (valuePtr->typePtr == &tclIntType) {
+ iResult = valuePtr->internalRep.longValue;
+ } else if (valuePtr->typePtr == &tclWideIntType) {
+ TclGetLongFromWide(iResult,valuePtr);
+ } else {
+ d = valuePtr->internalRep.doubleValue;
+ if (d < 0.0) {
+ if (d < (double) (long) LONG_MIN) {
+ tooLarge:
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "integer value too large to represent", -1));
+ Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW",
+ "integer value too large to represent",
+ (char *) NULL);
+ return TCL_ERROR;
+ }
+ } else {
+ if (d > (double) LONG_MAX) {
+ goto tooLarge;
+ }
+ }
+ if (IS_NAN(d) || IS_INF(d)) {
+ TclExprFloatError(interp, d);
+ return TCL_ERROR;
+ }
+ iResult = (long) d;
+ }
+ TclNewIntObj( oResult, iResult );
+ Tcl_SetObjResult( interp, oResult );
+ return TCL_OK;
+ }
+ }
+ return TCL_ERROR;
+}
+
+static int
+ExprWideFunc(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 */
+{
+
+ register Tcl_Obj *valuePtr;
+ Tcl_WideInt wResult;
+ double d;
+ Tcl_Obj* oResult;
+
+ if ( objc != 2 ) {
+ MathFuncWrongNumArgs( interp, 2, objc, objv );
+ } else {
+ valuePtr = objv[1];
+ if (VerifyExprObjType(interp, valuePtr) == TCL_OK) {
+ if (valuePtr->typePtr == &tclIntType) {
+ wResult = valuePtr->internalRep.longValue;
+ } else if (valuePtr->typePtr == &tclWideIntType) {
+ wResult = valuePtr->internalRep.wideValue;
+ } else {
+ d = valuePtr->internalRep.doubleValue;
+ if (d < 0.0) {
+ if (d < Tcl_WideAsDouble( LLONG_MIN ) ) {
+ tooLarge:
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "integer value too large to represent", -1));
+ Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW",
+ "integer value too large to represent",
+ (char *) NULL);
+ return TCL_ERROR;
+ }
+ } else {
+ if (d > Tcl_WideAsDouble( LLONG_MAX ) ) {
+ goto tooLarge;
+ }
+ }
+ if (IS_NAN(d) || IS_INF(d)) {
+ TclExprFloatError(interp, d);
+ return TCL_ERROR;
+ }
+ wResult = (Tcl_WideInt) d;
+ }
+ TclNewWideIntObj( oResult, wResult );
+ Tcl_SetObjResult( interp, oResult );
+ return TCL_OK;
+ }
+ }
+ return TCL_ERROR;
+}
+
+static int
+ExprRandFunc(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 */
+{
+ Interp *iPtr = (Interp *) interp;
+ double dResult;
+ long tmp; /* Algorithm assumes at least 32 bits.
+ * Only long guarantees that. See below. */
+ Tcl_Obj* oResult;
+
+ if ( objc != 1 ) {
+ MathFuncWrongNumArgs( interp, 1, objc, objv );
+ return TCL_ERROR;
+ }
+
+ if (!(iPtr->flags & RAND_SEED_INITIALIZED)) {
+ iPtr->flags |= RAND_SEED_INITIALIZED;
+
+ /*
+ * Take into consideration the thread this interp is running in order
+ * to insure different seeds in different threads (bug #416643)
+ */
+
+ iPtr->randSeed = TclpGetClicks() + ((long)Tcl_GetCurrentThread()<<12);
+
+ /*
+ * Make sure 1 <= randSeed <= (2^31) - 2. See below.
+ */
+
+ iPtr->randSeed &= (unsigned long) 0x7fffffff;
+ if ((iPtr->randSeed == 0) || (iPtr->randSeed == 0x7fffffff)) {
+ iPtr->randSeed ^= 123459876;
+ }
+ }
+
+ /*
+ * Generate the random number using the linear congruential
+ * generator defined by the following recurrence:
+ * seed = ( IA * seed ) mod IM
+ * where IA is 16807 and IM is (2^31) - 1. The recurrence maps
+ * a seed in the range [1, IM - 1] to a new seed in that same range.
+ * The recurrence maps IM to 0, and maps 0 back to 0, so those two
+ * values must not be allowed as initial values of seed.
+ *
+ * In order to avoid potential problems with integer overflow, the
+ * recurrence is implemented in terms of additional constants
+ * IQ and IR such that
+ * IM = IA*IQ + IR
+ * None of the operations in the implementation overflows a 32-bit
+ * signed integer, and the C type long is guaranteed to be at least
+ * 32 bits wide.
+ *
+ * For more details on how this algorithm works, refer to the following
+ * papers:
+ *
+ * S.K. Park & K.W. Miller, "Random number generators: good ones
+ * are hard to find," Comm ACM 31(10):1192-1201, Oct 1988
+ *
+ * W.H. Press & S.A. Teukolsky, "Portable random number
+ * generators," Computers in Physics 6(5):522-524, Sep/Oct 1992.
+ */
+
+#define RAND_IA 16807
+#define RAND_IM 2147483647
+#define RAND_IQ 127773
+#define RAND_IR 2836
+#define RAND_MASK 123459876
+
+ tmp = iPtr->randSeed/RAND_IQ;
+ iPtr->randSeed = RAND_IA*(iPtr->randSeed - tmp*RAND_IQ) - RAND_IR*tmp;
+ if (iPtr->randSeed < 0) {
+ iPtr->randSeed += RAND_IM;
+ }
+
+ /*
+ * Since the recurrence keeps seed values in the range [1, RAND_IM - 1],
+ * dividing by RAND_IM yields a double in the range (0, 1).
+ */
+
+ dResult = iPtr->randSeed * (1.0/RAND_IM);
+
+ /*
+ * Push a Tcl object with the result.
+ */
+
+ TclNewDoubleObj( oResult, dResult );
+ Tcl_SetObjResult( interp, oResult );
+ return TCL_OK;
+}
+
+static int
+ExprRoundFunc(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; /* Parameter vector */
+{
+ Tcl_Obj *valuePtr, *resPtr;
+ double d, a, f;
+
+ /* Check the argument count. */
+
+ 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) {
+ return TCL_ERROR;
+ }
+ if ((valuePtr->typePtr == &tclIntType) ||
+ (valuePtr->typePtr == &tclWideIntType)) {
+ return TCL_OK;
+ }
+ GET_DOUBLE_VALUE( d, valuePtr, valuePtr->typePtr );
+
+ /*
+ * Round the number to the nearest integer. I'd like to use rint()
+ * or nearbyint(), but they are far from universal.
+ */
+
+ a = fabs( d );
+ if ( a < Tcl_WideAsDouble( LLONG_MAX ) + 0.5 ) {
+ d = valuePtr->internalRep.doubleValue;
+ f = floor( d );
+ d -= f;
+ if ( d > 0.5 || ( d == 0.5 && fmod( f, 2.0 ) != 0.0 ) ) {
+ f = f + 1.0;
+ }
+ if ( f >= (double) LONG_MIN && f <= (double) LONG_MAX ) {
+ TclNewLongObj( resPtr, (long) f );
+ } else {
+ TclNewWideIntObj( resPtr, Tcl_DoubleAsWide( f ) );
+ }
+ Tcl_SetObjResult( interp, resPtr );
+ return TCL_OK;
+ }
+
+ /*
+ * Error return: result cannot be represented as an integer.
+ */
+
+ 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;
+
+}
+
+static int
+ExprSrandFunc(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; /* Parameter vector */
+{
+ Interp *iPtr = (Interp *) interp;
+ Tcl_Obj *valuePtr;
+ long i = 0; /* Initialized to avoid compiler warning. */
+
+ /*
+ * Convert argument and use it to reset the seed.
+ */
+
+ if (objc != 2 ) {
+ 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));
+ return TCL_ERROR;
+ }
+
+ /*
+ * Reset the seed. Make sure 1 <= randSeed <= 2^31 - 2.
+ * See comments in ExprRandFunc() for more details.
+ */
+
+ iPtr->flags |= RAND_SEED_INITIALIZED;
+ iPtr->randSeed = i;
+ iPtr->randSeed &= (unsigned long) 0x7fffffff;
+ if ((iPtr->randSeed == 0) || (iPtr->randSeed == 0x7fffffff)) {
+ iPtr->randSeed ^= 123459876;
+ }
+
+ /*
+ * To avoid duplicating the random number generation code we simply
+ * clean up our state and call the real random number function. That
+ * function will always succeed.
+ */
+
+ return ExprRandFunc(clientData, interp, 1, 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 number of arguments
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * An error message is stored in the interpreter result
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+MathFuncWrongNumArgs( interp, expected, found, objv )
+ Tcl_Interp* interp; /* Tcl interpreter */
+ int expected; /* Formal parameter count */
+ int found; /* Actual parameter count */
+ Tcl_Obj *CONST *objv; /* Actual parameter vector */
+{
+ Tcl_Obj* errorMessage;
+ CONST char* name = Tcl_GetString( objv[0] );
+ CONST char* tail = name + strlen( name );
+ while ( tail > name+1 ) {
+ --tail;
+ if ( *tail == ':' && tail[-1] == ':' ) {
+ name = tail+1;
+ break;
+ }
+ }
+ errorMessage = Tcl_NewStringObj( "too ", -1 );
+ if ( found < expected ) {
+ Tcl_AppendToObj( errorMessage, "few", -1 );
+ } else {
+ Tcl_AppendToObj( errorMessage, "many", -1 );
+ }
+ Tcl_AppendToObj( errorMessage, " arguments for math function \"", -1 );
+ Tcl_AppendToObj( errorMessage, name, -1 );
+ Tcl_AppendToObj( errorMessage, "\"", -1 );
+ Tcl_SetObjResult( interp, errorMessage );
+}
diff --git a/generic/tclBinary.c b/generic/tclBinary.c
index 1b613d8..706d1f0 100644
--- a/generic/tclBinary.c
+++ b/generic/tclBinary.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: tclBinary.c,v 1.21 2004/10/06 05:52:21 dgp Exp $
+ * RCS: @(#) $Id: tclBinary.c,v 1.22 2005/05/10 18:34:07 kennykb Exp $
*/
#include "tclInt.h"
@@ -1605,10 +1605,15 @@ FormatNumber(interp, type, src, cursorPtr)
case 'Q':
/*
* Double-precision floating point values.
+ * Tcl_GetDoubleFromObj returns TCL_ERROR for NaN, but
+ * we can check by comparing the object's type pointer.
*/
if (Tcl_GetDoubleFromObj(interp, src, &dvalue) != TCL_OK) {
- return TCL_ERROR;
+ if ( src->typePtr != &tclDoubleType ) {
+ return TCL_ERROR;
+ }
+ dvalue = src->internalRep.doubleValue;
}
CopyNumber(&dvalue, *cursorPtr, sizeof(double), type);
*cursorPtr += sizeof(double);
@@ -1619,10 +1624,14 @@ FormatNumber(interp, type, src, cursorPtr)
case 'R':
/*
* Single-precision floating point values.
+ * Tcl_GetDoubleFromObj returns TCL_ERROR for NaN, but
+ * we can check by comparing the object's type pointer.
*/
if (Tcl_GetDoubleFromObj(interp, src, &dvalue) != TCL_OK) {
- return TCL_ERROR;
+ if ( src->typePtr != &tclDoubleType ) {
+ return TCL_ERROR;
+ }
}
/*
diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c
index eb57690..c3037bc 100644
--- a/generic/tclCmdAH.c
+++ b/generic/tclCmdAH.c
@@ -11,7 +11,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclCmdAH.c,v 1.60 2005/04/19 16:32:55 dgp Exp $
+ * RCS: @(#) $Id: tclCmdAH.c,v 1.61 2005/05/10 18:34:08 kennykb Exp $
*/
#include "tclInt.h"
diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c
index 3b61959..7f67180 100644
--- a/generic/tclCmdIL.c
+++ b/generic/tclCmdIL.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: tclCmdIL.c,v 1.73 2005/05/05 18:37:56 dgp Exp $
+ * RCS: @(#) $Id: tclCmdIL.c,v 1.74 2005/05/10 18:34:08 kennykb Exp $
*/
#include "tclInt.h"
diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c
index 18da3f4..aee76d3 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.117 2005/04/29 20:49:43 dgp Exp $
+ * RCS: @(#) $Id: tclCmdMZ.c,v 1.118 2005/05/10 18:34:08 kennykb Exp $
*/
#include "tclInt.h"
@@ -1536,17 +1536,8 @@ Tcl_StringObjCmd(dummy, interp, objc, objv)
}
}
errno = 0;
- strtod(string1, &stop); /* INTL: Tcl source. */
- if (errno == ERANGE) {
- /*
- * if (errno == ERANGE), then it was an over/underflow
- * problem, but in this method, we only want to know
- * yes or no, so bad flow returns 0 (false) and sets
- * the failVarObj to the string length.
- */
- result = 0;
- failat = -1;
- } else if (stop == string1) {
+ TclStrToD(string1, (CONST char **) &stop); /* INTL: Tcl source. */
+ if (stop == string1) {
/*
* In this case, nothing like a number was found
*/
diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c
index bd0c4b7..da77439 100644
--- a/generic/tclCompCmds.c
+++ b/generic/tclCompCmds.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: tclCompCmds.c,v 1.67 2005/05/05 18:37:57 dgp Exp $
+ * RCS: @(#) $Id: tclCompCmds.c,v 1.68 2005/05/10 18:34:09 kennykb Exp $
*/
#include "tclInt.h"
diff --git a/generic/tclCompExpr.c b/generic/tclCompExpr.c
index e25160d..e378ef6 100644
--- a/generic/tclCompExpr.c
+++ b/generic/tclCompExpr.c
@@ -9,7 +9,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclCompExpr.c,v 1.25 2004/10/08 15:39:52 dkf Exp $
+ * RCS: @(#) $Id: tclCompExpr.c,v 1.26 2005/05/10 18:34:11 kennykb Exp $
*/
#include "tclInt.h"
@@ -828,95 +828,54 @@ CompileMathFuncCall(exprTokenPtr, funcName, infoPtr, envPtr, endPtrPtr)
* just after the last token in the
* subexpression is stored here. */
{
- Tcl_Interp *interp = infoPtr->interp;
- Interp *iPtr = (Interp *) interp;
- MathFunc *mathFuncPtr;
- Tcl_HashEntry *hPtr;
+ Tcl_DString cmdName;
+ int objIndex;
Tcl_Token *tokenPtr, *afterSubexprPtr;
- int code, i;
-
- /*
- * Look up the MathFunc record for the function.
- */
-
- code = TCL_OK;
- hPtr = Tcl_FindHashEntry(&iPtr->mathFuncTable, funcName);
- if (hPtr == NULL) {
- Tcl_AppendResult(interp, "unknown math function \"", funcName,
- "\"", (char *) NULL);
- code = TCL_ERROR;
- goto done;
- }
- mathFuncPtr = (MathFunc *) Tcl_GetHashValue(hPtr);
-
+ int argCount;
+ int code = TCL_OK;
+
/*
- * If not a builtin function, push an object with the function's name.
+ * Prepend "tcl::mathfunc::" to the function name, to produce the
+ * name of a command that evaluates the function. Push that
+ * command name on the stack, in a literal registered to the
+ * namespace so that resolution can be cached.
*/
- if (mathFuncPtr->builtinFuncIndex < 0) {
- TclEmitPush(TclRegisterNewLiteral(envPtr, funcName, -1), envPtr);
- }
+ Tcl_DStringInit( &cmdName );
+ Tcl_DStringAppend( &cmdName, "tcl::mathfunc::", -1 );
+ Tcl_DStringAppend( &cmdName, funcName, -1 );
+ objIndex = TclRegisterNewNSLiteral( envPtr,
+ Tcl_DStringValue( &cmdName ),
+ Tcl_DStringLength( &cmdName ) );
+ TclEmitPush( objIndex, envPtr );
+ Tcl_DStringFree( &cmdName );
/*
* Compile any arguments for the function.
*/
+ argCount = 1;
tokenPtr = exprTokenPtr+2;
afterSubexprPtr = exprTokenPtr + (exprTokenPtr->numComponents + 1);
- if (mathFuncPtr->numArgs > 0) {
- for (i = 0; i < mathFuncPtr->numArgs; i++) {
- if (tokenPtr == afterSubexprPtr) {
- Tcl_SetObjResult(interp, Tcl_NewStringObj(
- "too few arguments for math function", -1));
- code = TCL_ERROR;
- goto done;
- }
- code = CompileSubExpr(tokenPtr, infoPtr, envPtr);
- if (code != TCL_OK) {
- goto done;
- }
- tokenPtr += (tokenPtr->numComponents + 1);
+ while (tokenPtr != afterSubexprPtr) {
+ ++argCount;
+ code = CompileSubExpr(tokenPtr, infoPtr, envPtr);
+ if (code != TCL_OK) {
+ return code;
}
- if (tokenPtr != afterSubexprPtr) {
- Tcl_SetObjResult(interp, Tcl_NewStringObj(
- "too many arguments for math function", -1));
- code = TCL_ERROR;
- goto done;
- }
- } else if (tokenPtr != afterSubexprPtr) {
- Tcl_SetObjResult(interp, Tcl_NewStringObj(
- "too many arguments for math function", -1));
- code = TCL_ERROR;
- goto done;
+ tokenPtr += (tokenPtr->numComponents + 1);
}
- /*
- * Compile the call on the math function. Note that the "objc" argument
- * count for non-builtin functions is incremented by 1 to include the
- * function name itself.
- */
+ /* Invoke the function */
- if (mathFuncPtr->builtinFuncIndex >= 0) { /* a builtin function */
- /*
- * Adjust the current stack depth by the number of arguments
- * of the builtin function. This cannot be handled by the
- * TclEmitInstInt1 macro as the number of arguments is not
- * passed as an operand.
- */
-
- if (envPtr->maxStackDepth < envPtr->currStackDepth) {
- envPtr->maxStackDepth = envPtr->currStackDepth;
- }
- TclEmitInstInt1(INST_CALL_BUILTIN_FUNC1,
- mathFuncPtr->builtinFuncIndex, envPtr);
- envPtr->currStackDepth -= mathFuncPtr->numArgs;
+ if ( argCount < 255 ) {
+ TclEmitInstInt1( INST_INVOKE_STK1, argCount, envPtr );
} else {
- TclEmitInstInt1(INST_CALL_FUNC1, (mathFuncPtr->numArgs+1), envPtr);
+ TclEmitInstInt4( INST_INVOKE_STK4, argCount, envPtr );
}
- *endPtrPtr = afterSubexprPtr;
- done:
- return code;
+ *endPtrPtr = afterSubexprPtr;
+ return TCL_OK;
}
/*
diff --git a/generic/tclCompile.c b/generic/tclCompile.c
index 47b6831..f67fea6 100644
--- a/generic/tclCompile.c
+++ b/generic/tclCompile.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: tclCompile.c,v 1.84 2005/05/05 15:32:20 dgp Exp $
+ * RCS: @(#) $Id: tclCompile.c,v 1.85 2005/05/10 18:34:11 kennykb Exp $
*/
#include "tclInt.h"
diff --git a/generic/tclCompile.h b/generic/tclCompile.h
index 896b385..ab34f81 100644
--- a/generic/tclCompile.h
+++ b/generic/tclCompile.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: tclCompile.h,v 1.54 2005/03/25 00:35:03 dgp Exp $
+ * RCS: @(#) $Id: tclCompile.h,v 1.55 2005/05/10 18:34:27 kennykb Exp $
*/
#ifndef _TCLCOMPILATION
@@ -591,64 +591,6 @@ typedef struct InstructionDesc {
MODULE_SCOPE InstructionDesc tclInstructionTable[];
/*
- * Definitions of the values of the INST_CALL_BUILTIN_FUNC instruction's
- * operand byte. Each value denotes a builtin Tcl math function. These
- * values must correspond to the entries in the tclBuiltinFuncTable array
- * below and to the values stored in the tclInt.h MathFunc structure's
- * builtinFuncIndex field.
- */
-
-#define BUILTIN_FUNC_ACOS 0
-#define BUILTIN_FUNC_ASIN 1
-#define BUILTIN_FUNC_ATAN 2
-#define BUILTIN_FUNC_ATAN2 3
-#define BUILTIN_FUNC_CEIL 4
-#define BUILTIN_FUNC_COS 5
-#define BUILTIN_FUNC_COSH 6
-#define BUILTIN_FUNC_EXP 7
-#define BUILTIN_FUNC_FLOOR 8
-#define BUILTIN_FUNC_FMOD 9
-#define BUILTIN_FUNC_HYPOT 10
-#define BUILTIN_FUNC_LOG 11
-#define BUILTIN_FUNC_LOG10 12
-#define BUILTIN_FUNC_POW 13
-#define BUILTIN_FUNC_SIN 14
-#define BUILTIN_FUNC_SINH 15
-#define BUILTIN_FUNC_SQRT 16
-#define BUILTIN_FUNC_TAN 17
-#define BUILTIN_FUNC_TANH 18
-#define BUILTIN_FUNC_ABS 19
-#define BUILTIN_FUNC_DOUBLE 20
-#define BUILTIN_FUNC_INT 21
-#define BUILTIN_FUNC_RAND 22
-#define BUILTIN_FUNC_ROUND 23
-#define BUILTIN_FUNC_SRAND 24
-#define BUILTIN_FUNC_WIDE 25
-
-#define LAST_BUILTIN_FUNC 25
-
-/*
- * Table describing the built-in math functions. Entries in this table are
- * indexed by the values of the INST_CALL_BUILTIN_FUNC instruction's
- * operand byte.
- */
-
-typedef int (CallBuiltinFuncProc) _ANSI_ARGS_((Tcl_Interp *interp,
- Tcl_Obj **tosPtr, ClientData clientData));
-
-typedef struct {
- char *name; /* Name of function. */
- int numArgs; /* Number of arguments for function. */
- Tcl_ValueType argTypes[MAX_MATH_ARGS];
- /* Acceptable types for each argument. */
- CallBuiltinFuncProc *proc; /* Procedure implementing this function. */
- ClientData clientData; /* Additional argument to pass to the
- * function when invoking it. */
-} BuiltinFunc;
-
-MODULE_SCOPE BuiltinFunc tclBuiltinFuncTable[];
-
-/*
* Compilation of some Tcl constructs such as if commands and the logical or
* (||) and logical and (&&) operators in expressions requires the
* generation of forward jumps. Since the PC target of these jumps isn't
diff --git a/generic/tclConfig.c b/generic/tclConfig.c
index 4172fdb..f9c6dda 100644
--- a/generic/tclConfig.c
+++ b/generic/tclConfig.c
@@ -9,7 +9,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclConfig.c,v 1.7 2005/04/02 02:08:32 msofer Exp $
+ * RCS: @(#) $Id: tclConfig.c,v 1.8 2005/05/10 18:34:28 kennykb Exp $
*/
#include "tclInt.h"
diff --git a/generic/tclDecls.h b/generic/tclDecls.h
index 0ec588f..7ab10d3 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.112 2005/05/03 18:07:47 dgp Exp $
+ * RCS: @(#) $Id: tclDecls.h,v 1.113 2005/05/10 18:34:28 kennykb Exp $
*/
#ifndef _TCLDECLS
@@ -3461,6 +3461,29 @@ EXTERN void Tcl_QueryTimeProc _ANSI_ARGS_((
EXTERN Tcl_DriverThreadActionProc * Tcl_ChannelThreadActionProc _ANSI_ARGS_((
Tcl_ChannelType * chanTypePtr));
#endif
+#ifndef Tcl_NewBignumObj_TCL_DECLARED
+#define Tcl_NewBignumObj_TCL_DECLARED
+/* 555 */
+EXTERN Tcl_Obj* Tcl_NewBignumObj _ANSI_ARGS_((mp_int* value));
+#endif
+#ifndef Tcl_DbNewBignumObj_TCL_DECLARED
+#define Tcl_DbNewBignumObj_TCL_DECLARED
+/* 556 */
+EXTERN Tcl_Obj* Tcl_DbNewBignumObj _ANSI_ARGS_((mp_int* value,
+ CONST char* file, int line));
+#endif
+#ifndef Tcl_SetBignumObj_TCL_DECLARED
+#define Tcl_SetBignumObj_TCL_DECLARED
+/* 557 */
+EXTERN void Tcl_SetBignumObj _ANSI_ARGS_((Tcl_Obj* obj,
+ mp_int* value));
+#endif
+#ifndef Tcl_GetBignumFromObj_TCL_DECLARED
+#define Tcl_GetBignumFromObj_TCL_DECLARED
+/* 558 */
+EXTERN int Tcl_GetBignumFromObj _ANSI_ARGS_((Tcl_Interp* interp,
+ Tcl_Obj* obj, mp_int* value));
+#endif
typedef struct TclStubHooks {
struct TclPlatStubs *tclPlatStubs;
@@ -4057,6 +4080,10 @@ typedef struct TclStubs {
void (*tcl_SetTimeProc) _ANSI_ARGS_((Tcl_GetTimeProc* getProc, Tcl_ScaleTimeProc* scaleProc, ClientData clientData)); /* 552 */
void (*tcl_QueryTimeProc) _ANSI_ARGS_((Tcl_GetTimeProc** getProc, Tcl_ScaleTimeProc** scaleProc, ClientData* clientData)); /* 553 */
Tcl_DriverThreadActionProc * (*tcl_ChannelThreadActionProc) _ANSI_ARGS_((Tcl_ChannelType * chanTypePtr)); /* 554 */
+ Tcl_Obj* (*tcl_NewBignumObj) _ANSI_ARGS_((mp_int* value)); /* 555 */
+ 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 */
} TclStubs;
#ifdef __cplusplus
@@ -6317,6 +6344,22 @@ extern TclStubs *tclStubsPtr;
#define Tcl_ChannelThreadActionProc \
(tclStubsPtr->tcl_ChannelThreadActionProc) /* 554 */
#endif
+#ifndef Tcl_NewBignumObj
+#define Tcl_NewBignumObj \
+ (tclStubsPtr->tcl_NewBignumObj) /* 555 */
+#endif
+#ifndef Tcl_DbNewBignumObj
+#define Tcl_DbNewBignumObj \
+ (tclStubsPtr->tcl_DbNewBignumObj) /* 556 */
+#endif
+#ifndef Tcl_SetBignumObj
+#define Tcl_SetBignumObj \
+ (tclStubsPtr->tcl_SetBignumObj) /* 557 */
+#endif
+#ifndef Tcl_GetBignumFromObj
+#define Tcl_GetBignumFromObj \
+ (tclStubsPtr->tcl_GetBignumFromObj) /* 558 */
+#endif
#endif /* defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) */
diff --git a/generic/tclDictObj.c b/generic/tclDictObj.c
index 1dc87d4..5c40825 100644
--- a/generic/tclDictObj.c
+++ b/generic/tclDictObj.c
@@ -9,7 +9,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclDictObj.c,v 1.30 2005/05/05 18:37:58 dgp Exp $
+ * RCS: @(#) $Id: tclDictObj.c,v 1.31 2005/05/10 18:34:34 kennykb Exp $
*/
#include "tclInt.h"
diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c
index 13c517b..646713d 100644
--- a/generic/tclEncoding.c
+++ b/generic/tclEncoding.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: tclEncoding.c,v 1.34 2005/04/12 20:28:46 dgp Exp $
+ * RCS: @(#) $Id: tclEncoding.c,v 1.35 2005/05/10 18:34:34 kennykb Exp $
*/
#include "tclInt.h"
diff --git a/generic/tclEnv.c b/generic/tclEnv.c
index e4d7b23..4ceb4fb 100644
--- a/generic/tclEnv.c
+++ b/generic/tclEnv.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: tclEnv.c,v 1.23 2005/05/03 18:08:17 dgp Exp $
+ * RCS: @(#) $Id: tclEnv.c,v 1.24 2005/05/10 18:34:34 kennykb Exp $
*/
#include "tclInt.h"
diff --git a/generic/tclEvent.c b/generic/tclEvent.c
index 8d4533ec..6e2a4df 100644
--- a/generic/tclEvent.c
+++ b/generic/tclEvent.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: tclEvent.c,v 1.56 2004/12/16 19:36:17 dkf Exp $
+ * RCS: @(#) $Id: tclEvent.c,v 1.57 2005/05/10 18:34:35 kennykb Exp $
*/
#include "tclInt.h"
@@ -798,6 +798,8 @@ TclInitSubsystems()
#endif
TclpInitPlatform(); /* creates signal handler(s) */
+ TclInitDoubleConversion(); /* initializes constants for
+ * converting to/from double */
TclInitObjSubsystem(); /* register obj types, create mutexes */
TclInitIOSubsystem(); /* inits a tsd key (noop) */
TclInitEncodingSubsystem(); /* process wide encoding init */
@@ -938,6 +940,10 @@ Tcl_Finalize()
TclFinalizeLoad();
TclResetFilesystem();
+
+ /* Now we can free constants for conversions to/from double */
+
+ TclFinalizeDoubleConversion();
/*
* There shouldn't be any malloc'ed memory after this.
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index ad91579..3333c79 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.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: tclExecute.c,v 1.187 2005/05/10 10:02:16 msofer Exp $
+ * RCS: @(#) $Id: tclExecute.c,v 1.188 2005/05/10 18:34:35 kennykb Exp $
*/
#include "tclInt.h"
@@ -20,6 +20,18 @@
#ifndef TCL_NO_MATH
# include <math.h>
#endif
+#include <float.h>
+
+/*
+ * Hack to determine whether we may expect IEEE floating point.
+ * The hack is formally incorrect in that non-IEEE platforms might
+ * have the same precision and range, but VAX, IBM, and Cray do not;
+ * are there any other floating point units that we might care about?
+ */
+
+#if ( FLT_RADIX == 2 ) && ( DBL_MANT_DIG == 53 ) && ( DBL_MAX_EXP == 1024 )
+#define IEEE_FLOATING_POINT
+#endif
/*
* The stuff below is a bit of a hack so that this file can be used
@@ -136,8 +148,13 @@ long tclObjsShared[TCL_MAX_SHARED_OBJ_STATS] = { 0, 0, 0, 0, 0 };
* by comparing against the largest floating-point value.
*/
-#define IS_NAN(v) ((v) != (v))
-#define IS_INF(v) (((v) > DBL_MAX) || ((v) < -DBL_MAX))
+#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
@@ -345,26 +362,6 @@ long tclObjsShared[TCL_MAX_SHARED_OBJ_STATS] = { 0, 0, 0, 0, 0 };
static int TclExecuteByteCode _ANSI_ARGS_((Tcl_Interp *interp,
ByteCode *codePtr));
-static int ExprAbsFunc _ANSI_ARGS_((Tcl_Interp *interp,
- Tcl_Obj **tosPtr, ClientData clientData));
-static int ExprBinaryFunc _ANSI_ARGS_((Tcl_Interp *interp,
- Tcl_Obj **tosPtr, ClientData clientData));
-static int ExprCallMathFunc _ANSI_ARGS_((Tcl_Interp *interp,
- int objc, Tcl_Obj **objv));
-static int ExprDoubleFunc _ANSI_ARGS_((Tcl_Interp *interp,
- Tcl_Obj **tosPtr, ClientData clientData));
-static int ExprIntFunc _ANSI_ARGS_((Tcl_Interp *interp,
- Tcl_Obj **tosPtr, ClientData clientData));
-static int ExprRandFunc _ANSI_ARGS_((Tcl_Interp *interp,
- Tcl_Obj **tosPtr, ClientData clientData));
-static int ExprRoundFunc _ANSI_ARGS_((Tcl_Interp *interp,
- Tcl_Obj **tosPtr, ClientData clientData));
-static int ExprSrandFunc _ANSI_ARGS_((Tcl_Interp *interp,
- Tcl_Obj **tosPtr, ClientData clientData));
-static int ExprUnaryFunc _ANSI_ARGS_((Tcl_Interp *interp,
- Tcl_Obj **tosPtr, ClientData clientData));
-static int ExprWideFunc _ANSI_ARGS_((Tcl_Interp *interp,
- Tcl_Obj **tosPtr, ClientData clientData));
#ifdef TCL_COMPILE_STATS
static int EvalStatsCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc,
@@ -391,50 +388,11 @@ static void ValidatePcAndStackTop _ANSI_ARGS_((
int stackTop, int stackLowerBound,
int checkStack));
#endif /* TCL_COMPILE_DEBUG */
-static int VerifyExprObjType _ANSI_ARGS_((Tcl_Interp *interp,
- Tcl_Obj *objPtr));
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));
-/*
- * Table describing the built-in math functions. Entries in this table are
- * indexed by the values of the INST_CALL_BUILTIN_FUNC instruction's
- * operand byte.
- */
-
-BuiltinFunc tclBuiltinFuncTable[] = {
-#ifndef TCL_NO_MATH
- {"acos", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) acos},
- {"asin", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) asin},
- {"atan", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) atan},
- {"atan2", 2, {TCL_DOUBLE, TCL_DOUBLE}, ExprBinaryFunc, (ClientData) atan2},
- {"ceil", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) ceil},
- {"cos", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) cos},
- {"cosh", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) cosh},
- {"exp", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) exp},
- {"floor", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) floor},
- {"fmod", 2, {TCL_DOUBLE, TCL_DOUBLE}, ExprBinaryFunc, (ClientData) fmod},
- {"hypot", 2, {TCL_DOUBLE, TCL_DOUBLE}, ExprBinaryFunc, (ClientData) hypot},
- {"log", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) log},
- {"log10", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) log10},
- {"pow", 2, {TCL_DOUBLE, TCL_DOUBLE}, ExprBinaryFunc, (ClientData) pow},
- {"sin", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) sin},
- {"sinh", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) sinh},
- {"sqrt", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) sqrt},
- {"tan", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) tan},
- {"tanh", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) tanh},
-#endif
- {"abs", 1, {TCL_EITHER}, ExprAbsFunc, 0},
- {"double", 1, {TCL_EITHER}, ExprDoubleFunc, 0},
- {"int", 1, {TCL_EITHER}, ExprIntFunc, 0},
- {"rand", 0, {TCL_EITHER}, ExprRandFunc, 0}, /* NOTE: rand takes no args. */
- {"round", 1, {TCL_EITHER}, ExprRoundFunc, 0},
- {"srand", 1, {TCL_INT}, ExprSrandFunc, 0},
- {"wide", 1, {TCL_EITHER}, ExprWideFunc, 0},
- {0},
-};
/*
*----------------------------------------------------------------------
@@ -4023,10 +3981,18 @@ TclExecuteByteCode(interp, codePtr)
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:
@@ -4042,7 +4008,7 @@ TclExecuteByteCode(interp, codePtr)
* Check now for IEEE floating-point error.
*/
- if (IS_NAN(dResult) || IS_INF(dResult)) {
+ if (IS_NAN(dResult)) {
TRACE(("%.20s %.20s => IEEE FLOATING PT ERROR\n",
O2S(valuePtr), O2S(value2Ptr)));
TclExprFloatError(interp, dResult);
@@ -4430,53 +4396,13 @@ TclExecuteByteCode(interp, codePtr)
case INST_CALL_BUILTIN_FUNC1:
{
- int opnd;
- BuiltinFunc *mathFuncPtr;
-
- /*
- * Call one of the built-in Tcl math functions.
- */
-
- opnd = TclGetUInt1AtPtr(pc+1);
- if ((opnd < 0) || (opnd > LAST_BUILTIN_FUNC)) {
- TRACE(("UNRECOGNIZED BUILTIN FUNC CODE %d\n", opnd));
- Tcl_Panic("TclExecuteByteCode: unrecognized builtin function code %d", opnd);
- }
- mathFuncPtr = &(tclBuiltinFuncTable[opnd]);
- result = (*mathFuncPtr->proc)(interp, tosPtr,
- mathFuncPtr->clientData);
- if (result != TCL_OK) {
- goto checkForCatch;
- }
- tosPtr -= (mathFuncPtr->numArgs - 1);
- TRACE_WITH_OBJ(("%d => ", opnd), *tosPtr);
+ Tcl_Panic("TclExecuteByteCode: obsolete INST_CALL_BUILTIN_FUNC1 found");
}
- NEXT_INST_F(2, 0, 0);
case INST_CALL_FUNC1:
{
- /*
- * Call a non-builtin Tcl math function previously
- * registered by a call to Tcl_CreateMathFunc.
- */
-
- int objc; /* Number of arguments. The function name
- * is the 0-th argument. */
- Tcl_Obj **objv; /* The array of arguments. The function
- * name is objv[0]. */
-
- objc = TclGetUInt1AtPtr(pc+1);
- objv = (tosPtr - (objc-1)); /* "objv[0]" */
- DECACHE_STACK_INFO();
- result = ExprCallMathFunc(interp, objc, objv);
- CACHE_STACK_INFO();
- if (result != TCL_OK) {
- goto checkForCatch;
- }
- tosPtr = objv;
- TRACE_WITH_OBJ(("%d => ", objc), *tosPtr);
+ Tcl_Panic("TclExecuteByteCode: obsolete INST_CALL_FUNC1 found");
}
- NEXT_INST_F(2, 0, 0);
case INST_TRY_CVT_TO_NUMERIC:
{
@@ -4569,7 +4495,7 @@ TclExecuteByteCode(interp, codePtr)
if (tPtr == &tclDoubleType) {
d = objResultPtr->internalRep.doubleValue;
- if (IS_NAN(d) || IS_INF(d)) {
+ if (IS_NAN(d)) {
TRACE(("\"%.20s\" => IEEE FLOATING PT ERROR\n",
O2S(objResultPtr)));
TclExprFloatError(interp, d);
@@ -5594,765 +5520,6 @@ GetOpcodeName(pc)
/*
*----------------------------------------------------------------------
*
- * VerifyExprObjType --
- *
- * This procedure is called by the math functions to verify that
- * the object is either an int or double, coercing it if necessary.
- * If an error occurs during conversion, an error message is left
- * in the interpreter's result unless "interp" is NULL.
- *
- * Results:
- * TCL_OK if it was int or double, TCL_ERROR otherwise
- *
- * Side effects:
- * objPtr is ensured to be 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;
- }
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * Math Functions --
- *
- * This page contains the procedures that implement all of the
- * built-in math functions for expressions.
- *
- * Results:
- * Each procedure returns TCL_OK if it succeeds and pushes an
- * Tcl object holding the result. If it fails it returns TCL_ERROR
- * and leaves an error message in the interpreter's result.
- *
- * Side effects:
- * None.
- *
- *----------------------------------------------------------------------
- */
-
-static int
-ExprUnaryFunc(interp, tosPtr, clientData)
- Tcl_Interp *interp; /* The interpreter in which to execute the
- * function. */
- Tcl_Obj **tosPtr; /* Points to top of evaluation stack. */
- ClientData clientData; /* Contains the address of a procedure that
- * takes one double argument and returns a
- * double result. */
-{
- register Tcl_Obj *valuePtr, *resPtr;
- double d, dResult;
-
- double (*func) _ANSI_ARGS_((double)) =
- (double (*)_ANSI_ARGS_((double))) clientData;
-
- /*
- * Pop the function's argument from the evaluation stack. Convert it
- * to a double if necessary.
- */
-
- valuePtr = POP_OBJECT();
-
- if (VerifyExprObjType(interp, valuePtr) != TCL_OK) {
- return TCL_ERROR;
- }
-
- GET_DOUBLE_VALUE(d, valuePtr, valuePtr->typePtr);
-
- errno = 0;
- dResult = (*func)(d);
- if ((errno != 0) || IS_NAN(dResult) || IS_INF(dResult)) {
- TclExprFloatError(interp, dResult);
- return TCL_ERROR;
- }
-
- /*
- * Push a Tcl object holding the result.
- */
-
- TclNewDoubleObj(resPtr, dResult);
- PUSH_OBJECT(resPtr);
- TclDecrRefCount(valuePtr);
- return TCL_OK;
-}
-
-static int
-ExprBinaryFunc(interp, tosPtr, clientData)
- Tcl_Interp *interp; /* The interpreter in which to execute the
- * function. */
- Tcl_Obj **tosPtr; /* Points to top of evaluation stack. */
- ClientData clientData; /* Contains the address of a procedure that
- * takes two double arguments and
- * returns a double result. */
-{
- register Tcl_Obj *valuePtr, *value2Ptr, *resPtr;
- double d1, d2, dResult;
-
- double (*func) _ANSI_ARGS_((double, double))
- = (double (*)_ANSI_ARGS_((double, double))) clientData;
-
- /*
- * Pop the function's two arguments from the evaluation stack. Convert
- * them to doubles if necessary.
- */
-
- value2Ptr = POP_OBJECT();
- valuePtr = POP_OBJECT();
-
- if ((VerifyExprObjType(interp, valuePtr) != TCL_OK) ||
- (VerifyExprObjType(interp, value2Ptr) != TCL_OK)) {
- return TCL_ERROR;
- }
-
- GET_DOUBLE_VALUE(d1, valuePtr, valuePtr->typePtr);
- GET_DOUBLE_VALUE(d2, value2Ptr, value2Ptr->typePtr);
-
- errno = 0;
- dResult = (*func)(d1, d2);
- if ((errno != 0) || IS_NAN(dResult) || IS_INF(dResult)) {
- TclExprFloatError(interp, dResult);
- return TCL_ERROR;
- }
-
- /*
- * Push a Tcl object holding the result.
- */
-
- TclNewDoubleObj(resPtr, dResult);
- PUSH_OBJECT(resPtr);
- TclDecrRefCount(valuePtr);
- TclDecrRefCount(value2Ptr);
- return TCL_OK;
-}
-
-static int
-ExprAbsFunc(interp, tosPtr, clientData)
- Tcl_Interp *interp; /* The interpreter in which to execute the
- * function. */
- Tcl_Obj **tosPtr; /* Points to top of evaluation stack. */
- ClientData clientData; /* Ignored. */
-{
- register Tcl_Obj *valuePtr, *resPtr;
- long i, iResult;
- double d, dResult;
-
- /*
- * Pop the argument from the evaluation stack.
- */
-
- valuePtr = POP_OBJECT();
-
- if (VerifyExprObjType(interp, valuePtr) != TCL_OK) {
- return TCL_ERROR;
- }
-
- /*
- * Push a Tcl object with the result.
- */
- if (valuePtr->typePtr == &tclIntType) {
- i = valuePtr->internalRep.longValue;
- if (i < 0) {
- iResult = -i;
- if (iResult < 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;
- }
- } else {
- iResult = i;
- }
- TclNewLongObj(resPtr, iResult);
- PUSH_OBJECT(resPtr);
- } else if (valuePtr->typePtr == &tclWideIntType) {
- Tcl_WideInt wResult, w;
- TclGetWide(w,valuePtr);
- if (w < W0) {
- 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;
- }
- } else {
- wResult = w;
- }
- TclNewWideIntObj(resPtr, wResult);
- PUSH_OBJECT(resPtr);
- } else {
- d = valuePtr->internalRep.doubleValue;
- if (d < 0.0) {
- dResult = -d;
- } else {
- dResult = d;
- }
- if (IS_NAN(dResult) || IS_INF(dResult)) {
- TclExprFloatError(interp, dResult);
- return TCL_ERROR;
- }
- TclNewDoubleObj(resPtr, dResult);
- PUSH_OBJECT(resPtr);
- }
-
- TclDecrRefCount(valuePtr);
- return TCL_OK;
-}
-
-static int
-ExprDoubleFunc(interp, tosPtr, clientData)
- Tcl_Interp *interp; /* The interpreter in which to execute the
- * function. */
- Tcl_Obj **tosPtr; /* Points to top of evaluation stack. */
- ClientData clientData; /* Ignored. */
-{
- register Tcl_Obj *valuePtr, *resPtr;
- double dResult;
-
- /*
- * Pop the argument from the evaluation stack.
- */
-
- valuePtr = POP_OBJECT();
-
- if (VerifyExprObjType(interp, valuePtr) != TCL_OK) {
- return TCL_ERROR;
- }
-
- GET_DOUBLE_VALUE(dResult, valuePtr, valuePtr->typePtr);
-
- /*
- * Push a Tcl object with the result.
- */
-
- TclNewDoubleObj(resPtr, dResult);
- PUSH_OBJECT(resPtr);
-
- TclDecrRefCount(valuePtr);
- return TCL_OK;
-}
-
-static int
-ExprIntFunc(interp, tosPtr, clientData)
- Tcl_Interp *interp; /* The interpreter in which to execute the
- * function. */
- Tcl_Obj **tosPtr; /* Points to top of evaluation stack. */
- ClientData clientData; /* Ignored. */
-{
- register Tcl_Obj *valuePtr, *resPtr;
- long iResult;
- double d;
-
- /*
- * Pop the argument from the evaluation stack.
- */
-
- valuePtr = POP_OBJECT();
-
- if (VerifyExprObjType(interp, valuePtr) != TCL_OK) {
- return TCL_ERROR;
- }
-
- if (valuePtr->typePtr == &tclIntType) {
- iResult = valuePtr->internalRep.longValue;
- } else if (valuePtr->typePtr == &tclWideIntType) {
- TclGetLongFromWide(iResult,valuePtr);
- } else {
- d = valuePtr->internalRep.doubleValue;
- if (d < 0.0) {
- if (d < (double) (long) LONG_MIN) {
- tooLarge:
- Tcl_SetObjResult(interp, Tcl_NewStringObj(
- "integer value too large to represent", -1));
- Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW",
- "integer value too large to represent", (char *) NULL);
- return TCL_ERROR;
- }
- } else {
- if (d > (double) LONG_MAX) {
- goto tooLarge;
- }
- }
- if (IS_NAN(d) || IS_INF(d)) {
- TclExprFloatError(interp, d);
- return TCL_ERROR;
- }
- iResult = (long) d;
- }
-
- /*
- * Push a Tcl object with the result.
- */
-
- TclNewLongObj(resPtr, iResult);
- PUSH_OBJECT(resPtr);
- TclDecrRefCount(valuePtr);
- return TCL_OK;
-}
-
-static int
-ExprWideFunc(interp, tosPtr, clientData)
- Tcl_Interp *interp; /* The interpreter in which to execute the
- * function. */
- Tcl_Obj **tosPtr; /* Points to top of evaluation stack. */
- ClientData clientData; /* Ignored. */
-{
- register Tcl_Obj *valuePtr, *resPtr;
- Tcl_WideInt wResult;
- double d;
-
- /*
- * Pop the argument from the evaluation stack.
- */
-
- valuePtr = POP_OBJECT();
-
- if (VerifyExprObjType(interp, valuePtr) != TCL_OK) {
- return TCL_ERROR;
- }
-
- if (valuePtr->typePtr == &tclWideIntType) {
- TclGetWide(wResult,valuePtr);
- } else if (valuePtr->typePtr == &tclIntType) {
- wResult = Tcl_LongAsWide(valuePtr->internalRep.longValue);
- } else {
- d = valuePtr->internalRep.doubleValue;
- if (d < 0.0) {
- if (d < Tcl_WideAsDouble(LLONG_MIN)) {
- tooLarge:
- Tcl_SetObjResult(interp, Tcl_NewStringObj(
- "integer value too large to represent", -1));
- Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW",
- "integer value too large to represent", (char *) NULL);
- return TCL_ERROR;
- }
- } else {
- if (d > Tcl_WideAsDouble(LLONG_MAX)) {
- goto tooLarge;
- }
- }
- if (IS_NAN(d) || IS_INF(d)) {
- TclExprFloatError(interp, d);
- return TCL_ERROR;
- }
- wResult = Tcl_DoubleAsWide(d);
- }
-
- /*
- * Push a Tcl object with the result.
- */
-
- TclNewWideIntObj(resPtr, wResult);
- PUSH_OBJECT(resPtr);
- TclDecrRefCount(valuePtr);
- return TCL_OK;
-}
-
-static int
-ExprRandFunc(interp, tosPtr, clientData)
- Tcl_Interp *interp; /* The interpreter in which to execute the
- * function. */
- Tcl_Obj **tosPtr; /* Points to top of evaluation stack. */
- ClientData clientData; /* Ignored. */
-{
- Interp *iPtr = (Interp *) interp;
- double dResult;
- long tmp; /* Algorithm assumes at least 32 bits.
- * Only long guarantees that. See below. */
- Tcl_Obj *resPtr;
-
- if (!(iPtr->flags & RAND_SEED_INITIALIZED)) {
- iPtr->flags |= RAND_SEED_INITIALIZED;
-
- /*
- * Take into consideration the thread this interp is running in order
- * to insure different seeds in different threads (bug #416643)
- */
-
- iPtr->randSeed = TclpGetClicks() + ((long)Tcl_GetCurrentThread()<<12);
-
- /*
- * Make sure 1 <= randSeed <= (2^31) - 2. See below.
- */
-
- iPtr->randSeed &= (unsigned long) 0x7fffffff;
- if ((iPtr->randSeed == 0) || (iPtr->randSeed == 0x7fffffff)) {
- iPtr->randSeed ^= 123459876;
- }
- }
-
- /*
- * Generate the random number using the linear congruential
- * generator defined by the following recurrence:
- * seed = ( IA * seed ) mod IM
- * where IA is 16807 and IM is (2^31) - 1. The recurrence maps
- * a seed in the range [1, IM - 1] to a new seed in that same range.
- * The recurrence maps IM to 0, and maps 0 back to 0, so those two
- * values must not be allowed as initial values of seed.
- *
- * In order to avoid potential problems with integer overflow, the
- * recurrence is implemented in terms of additional constants
- * IQ and IR such that
- * IM = IA*IQ + IR
- * None of the operations in the implementation overflows a 32-bit
- * signed integer, and the C type long is guaranteed to be at least
- * 32 bits wide.
- *
- * For more details on how this algorithm works, refer to the following
- * papers:
- *
- * S.K. Park & K.W. Miller, "Random number generators: good ones
- * are hard to find," Comm ACM 31(10):1192-1201, Oct 1988
- *
- * W.H. Press & S.A. Teukolsky, "Portable random number
- * generators," Computers in Physics 6(5):522-524, Sep/Oct 1992.
- */
-
-#define RAND_IA 16807
-#define RAND_IM 2147483647
-#define RAND_IQ 127773
-#define RAND_IR 2836
-#define RAND_MASK 123459876
-
- tmp = iPtr->randSeed/RAND_IQ;
- iPtr->randSeed = RAND_IA*(iPtr->randSeed - tmp*RAND_IQ) - RAND_IR*tmp;
- if (iPtr->randSeed < 0) {
- iPtr->randSeed += RAND_IM;
- }
-
- /*
- * Since the recurrence keeps seed values in the range [1, RAND_IM - 1],
- * dividing by RAND_IM yields a double in the range (0, 1).
- */
-
- dResult = iPtr->randSeed * (1.0/RAND_IM);
-
- /*
- * Push a Tcl object with the result.
- */
-
- TclNewDoubleObj(resPtr, dResult);
- PUSH_OBJECT(resPtr);
- return TCL_OK;
-}
-
-static int
-ExprRoundFunc(interp, tosPtr, clientData)
- Tcl_Interp *interp; /* The interpreter in which to execute the
- * function. */
- Tcl_Obj **tosPtr; /* Points to top of evaluation stack. */
- ClientData clientData; /* Ignored. */
-{
- Tcl_Obj *valuePtr, *resPtr;
- double d;
-
- /*
- * Pop the argument from the evaluation stack.
- */
-
- valuePtr = POP_OBJECT();
-
- if (VerifyExprObjType(interp, valuePtr) != TCL_OK) {
- return TCL_ERROR;
- }
-
- if ((valuePtr->typePtr == &tclIntType) ||
- (valuePtr->typePtr == &tclWideIntType)) {
- return TCL_OK;
- }
-
- d = valuePtr->internalRep.doubleValue;
- if (d < 0.0) {
- if (d <= Tcl_WideAsDouble(LLONG_MIN)-0.5) {
- goto tooLarge;
- } else if (d <= (((double) (long) LONG_MIN) - 0.5)) {
- TclNewWideIntObj(resPtr, Tcl_DoubleAsWide(d - 0.5));
- } else {
- TclNewLongObj(resPtr, (long) (d - 0.5));
- }
- } else {
- if (d >= Tcl_WideAsDouble(LLONG_MAX)+0.5) {
- goto tooLarge;
- } else if (d >= (((double) LONG_MAX + 0.5))) {
- TclNewWideIntObj(resPtr, Tcl_DoubleAsWide(d + 0.5));
- } else {
- TclNewLongObj(resPtr, (long) (d + 0.5));
- }
- }
-
- /*
- * Free the argument Tcl_Obj and push the result object.
- */
-
- TclDecrRefCount(valuePtr);
- PUSH_OBJECT(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);
- return TCL_ERROR;
-}
-
-static int
-ExprSrandFunc(interp, tosPtr, clientData)
- Tcl_Interp *interp; /* The interpreter in which to execute the
- * function. */
- Tcl_Obj **tosPtr; /* Points to top of evaluation stack. */
- ClientData clientData; /* Ignored. */
-{
- Interp *iPtr = (Interp *) interp;
- Tcl_Obj *valuePtr;
- long i = 0; /* Initialized to avoid compiler warning. */
-
- /*
- * Pop the argument from the evaluation stack. Use the value
- * to reset the random number seed.
- */
-
- valuePtr = POP_OBJECT();
-
- 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));
- return TCL_ERROR;
- }
-
- /*
- * Reset the seed. Make sure 1 <= randSeed <= 2^31 - 2.
- * See comments in ExprRandFunc() for more details.
- */
-
- iPtr->flags |= RAND_SEED_INITIALIZED;
- iPtr->randSeed = i;
- iPtr->randSeed &= (unsigned long) 0x7fffffff;
- if ((iPtr->randSeed == 0) || (iPtr->randSeed == 0x7fffffff)) {
- iPtr->randSeed ^= 123459876;
- }
-
- /*
- * To avoid duplicating the random number generation code we simply
- * clean up our state and call the real random number function. That
- * function will always succeed.
- */
-
- TclDecrRefCount(valuePtr);
- ExprRandFunc(interp, tosPtr, clientData);
- return TCL_OK;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * ExprCallMathFunc --
- *
- * This procedure is invoked to call a non-builtin math function
- * during the execution of an expression.
- *
- * Results:
- * TCL_OK is returned if all went well and the function's value
- * was computed successfully. If an error occurred, TCL_ERROR
- * is returned and an error message is left in the interpreter's
- * result. After a successful return this procedure pops its
- * objc arguments and pushes a Tcl object holding the result.
- *
- * Side effects:
- * None, unless the called math function has side effects.
- *
- *----------------------------------------------------------------------
- */
-
-static int
-ExprCallMathFunc(interp, objc, objv)
- Tcl_Interp *interp; /* The interpreter in which to execute the
- * function. */
- int objc; /* Number of arguments. The function name is
- * the 0-th argument. */
- Tcl_Obj **objv; /* The array of arguments. The function name
- * is objv[0]. */
-{
- Interp *iPtr = (Interp *) interp;
- char *funcName;
- Tcl_HashEntry *hPtr;
- MathFunc *mathFuncPtr; /* Information about math function. */
- Tcl_Value args[MAX_MATH_ARGS]; /* Arguments for function call. */
- Tcl_Value funcResult; /* Result of function call as Tcl_Value. */
- register Tcl_Obj *valuePtr;
- long i;
- double d;
- int j, k, result;
-
- Tcl_ResetResult(interp);
-
- /*
- * Look up the MathFunc record for the function.
- */
-
- funcName = TclGetString(objv[0]);
- hPtr = Tcl_FindHashEntry(&iPtr->mathFuncTable, funcName);
- if (hPtr == NULL) {
- Tcl_AppendResult(interp, "unknown math function \"", funcName,
- "\"", (char *) NULL);
- return TCL_ERROR;
- }
- mathFuncPtr = (MathFunc *) Tcl_GetHashValue(hPtr);
- if (mathFuncPtr->numArgs != (objc-1)) {
- Tcl_Panic("ExprCallMathFunc: expected number of args %d != actual number %d",
- mathFuncPtr->numArgs, objc);
- return TCL_ERROR;
- }
-
- /*
- * Collect the arguments for the function, if there are any, into the
- * array "args". Note that args[0] will have the Tcl_Value that
- * corresponds to objv[1].
- */
-
- for (j = 1, k = 0; j < objc; j++, k++) {
- valuePtr = objv[j];
-
- if (VerifyExprObjType(interp, valuePtr) != TCL_OK) {
- return TCL_ERROR;
- }
-
- /*
- * Copy the object's numeric value to the argument record,
- * converting it if necessary.
- */
-
- if (valuePtr->typePtr == &tclIntType) {
- i = valuePtr->internalRep.longValue;
- if (mathFuncPtr->argTypes[k] == TCL_DOUBLE) {
- args[k].type = TCL_DOUBLE;
- args[k].doubleValue = i;
- } else if (mathFuncPtr->argTypes[k] == TCL_WIDE_INT) {
- args[k].type = TCL_WIDE_INT;
- args[k].wideValue = Tcl_LongAsWide(i);
- } else {
- args[k].type = TCL_INT;
- args[k].intValue = i;
- }
- } else if (valuePtr->typePtr == &tclWideIntType) {
- Tcl_WideInt w;
- TclGetWide(w,valuePtr);
- if (mathFuncPtr->argTypes[k] == TCL_DOUBLE) {
- args[k].type = TCL_DOUBLE;
- args[k].doubleValue = Tcl_WideAsDouble(w);
- } else if (mathFuncPtr->argTypes[k] == TCL_INT) {
- args[k].type = TCL_INT;
- args[k].intValue = Tcl_WideAsLong(w);
- } else {
- args[k].type = TCL_WIDE_INT;
- args[k].wideValue = w;
- }
- } else {
- d = valuePtr->internalRep.doubleValue;
- if (mathFuncPtr->argTypes[k] == TCL_INT) {
- args[k].type = TCL_INT;
- args[k].intValue = (long) d;
- } else if (mathFuncPtr->argTypes[k] == TCL_WIDE_INT) {
- args[k].type = TCL_WIDE_INT;
- args[k].wideValue = Tcl_DoubleAsWide(d);
- } else {
- args[k].type = TCL_DOUBLE;
- args[k].doubleValue = d;
- }
- }
- }
-
- /*
- * Invoke the function and copy its result back into valuePtr.
- */
-
- result = (*mathFuncPtr->proc)(mathFuncPtr->clientData, interp, args,
- &funcResult);
- if (result != TCL_OK) {
- return result;
- }
-
- /*
- * Pop the objc top stack elements and decrement their ref counts.
- */
-
- for (k = 0; k < objc; k++) {
- valuePtr = objv[k];
- TclDecrRefCount(valuePtr);
- }
-
- /*
- * Push the call's object result.
- */
-
- if (funcResult.type == TCL_INT) {
- TclNewLongObj(objv[0], funcResult.intValue);
- } else if (funcResult.type == TCL_WIDE_INT) {
- TclNewWideIntObj(objv[0], funcResult.wideValue);
- } else {
- d = funcResult.doubleValue;
- if (IS_NAN(d) || IS_INF(d)) {
- TclExprFloatError(interp, d);
- return TCL_ERROR;
- }
- TclNewDoubleObj(objv[0], d);
- }
- Tcl_IncrRefCount(objv[0]);
-
- return result;
-}
-
-/*
- *----------------------------------------------------------------------
- *
* TclExprFloatError --
*
* This procedure is called when an error occurs during a
diff --git a/generic/tclFCmd.c b/generic/tclFCmd.c
index 024526e..f8606e5 100644
--- a/generic/tclFCmd.c
+++ b/generic/tclFCmd.c
@@ -9,7 +9,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclFCmd.c,v 1.31 2005/01/14 18:56:32 vincentdarley Exp $
+ * RCS: @(#) $Id: tclFCmd.c,v 1.32 2005/05/10 18:34:37 kennykb Exp $
*/
#include "tclInt.h"
diff --git a/generic/tclFileName.c b/generic/tclFileName.c
index bde0071..5bfad99 100644
--- a/generic/tclFileName.c
+++ b/generic/tclFileName.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: tclFileName.c,v 1.68 2005/04/20 15:13:39 kennykb Exp $
+ * RCS: @(#) $Id: tclFileName.c,v 1.69 2005/05/10 18:34:38 kennykb Exp $
*/
#include "tclInt.h"
diff --git a/generic/tclGet.c b/generic/tclGet.c
index 1804088..be3d942 100644
--- a/generic/tclGet.c
+++ b/generic/tclGet.c
@@ -11,7 +11,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclGet.c,v 1.14 2005/05/03 18:08:18 dgp Exp $
+ * RCS: @(#) $Id: tclGet.c,v 1.15 2005/05/10 18:34:38 kennykb Exp $
*/
#include "tclInt.h"
diff --git a/generic/tclGetDate.y b/generic/tclGetDate.y
index 0be34be..800c04b 100644
--- a/generic/tclGetDate.y
+++ b/generic/tclGetDate.y
@@ -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: tclGetDate.y,v 1.26 2004/12/29 20:57:27 kennykb Exp $
+ * RCS: @(#) $Id: tclGetDate.y,v 1.27 2005/05/10 18:34:38 kennykb Exp $
*/
%{
diff --git a/generic/tclIO.c b/generic/tclIO.c
index e94264a..ee37035 100644
--- a/generic/tclIO.c
+++ b/generic/tclIO.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: tclIO.c,v 1.85 2005/05/05 18:37:58 dgp Exp $
+ * RCS: @(#) $Id: tclIO.c,v 1.86 2005/05/10 18:34:38 kennykb Exp $
*/
#include "tclInt.h"
diff --git a/generic/tclIOCmd.c b/generic/tclIOCmd.c
index fc14619..abd789c 100644
--- a/generic/tclIOCmd.c
+++ b/generic/tclIOCmd.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: tclIOCmd.c,v 1.23 2005/04/27 18:48:25 dgp Exp $
+ * RCS: @(#) $Id: tclIOCmd.c,v 1.24 2005/05/10 18:34:40 kennykb Exp $
*/
#include "tclInt.h"
diff --git a/generic/tclIOUtil.c b/generic/tclIOUtil.c
index 17d6efa..f94a3c8 100644
--- a/generic/tclIOUtil.c
+++ b/generic/tclIOUtil.c
@@ -17,7 +17,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclIOUtil.c,v 1.117 2005/04/27 18:48:25 dgp Exp $
+ * RCS: @(#) $Id: tclIOUtil.c,v 1.118 2005/05/10 18:34:40 kennykb Exp $
*/
#include "tclInt.h"
diff --git a/generic/tclInt.decls b/generic/tclInt.decls
index a997c25..c457741 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.87 2005/05/05 18:38:00 dgp Exp $
+# RCS: @(#) $Id: tclInt.decls,v 1.88 2005/05/10 18:34:41 kennykb Exp $
library tcl
@@ -874,6 +874,23 @@ declare 218 generic {
void TclPopStackFrame(Tcl_Interp *interp)
}
+# Entries in tommath needed only by tcltest
+
+declare 219 generic {
+ int TclBN_mp_div_d(mp_int *a, mp_digit b, mp_int *c, mp_digit *d)
+}
+declare 220 generic {
+ int TclBN_mp_mul_d(mp_int *a, mp_digit b, mp_int *c)
+}
+declare 221 generic {
+ void TclBN_mp_clear(mp_int *a)
+}
+declare 222 generic {
+ int TclBN_mp_init(mp_int *a)
+}
+declare 223 generic {
+ int TclBN_mp_read_radix(mp_int *a, const char *str, int radix)
+}
##############################################################################
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 6af07ff..0a05edb 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -12,7 +12,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclInt.h,v 1.228 2005/05/05 18:38:01 dgp Exp $
+ * RCS: @(#) $Id: tclInt.h,v 1.229 2005/05/10 18:34:42 kennykb Exp $
*/
#ifndef _TCLINT
@@ -1852,10 +1852,14 @@ MODULE_SCOPE void TclAppendObjToErrorInfo _ANSI_ARGS_((
Tcl_Interp *interp, Tcl_Obj *objPtr));
MODULE_SCOPE int TclArraySet _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Obj *arrayNameObj, Tcl_Obj *arrayElemObj));
+MODULE_SCOPE double TclBignumToDouble _ANSI_ARGS_((mp_int* bignum));
MODULE_SCOPE int TclCheckBadOctal _ANSI_ARGS_((Tcl_Interp *interp,
CONST char *value));
MODULE_SCOPE void TclCleanupLiteralTable _ANSI_ARGS_((
Tcl_Interp* interp, LiteralTable* tablePtr));
+MODULE_SCOPE int TclDoubleDigits _ANSI_ARGS_((char* buf,
+ double value,
+ int* signum));
MODULE_SCOPE void TclExpandTokenArray _ANSI_ARGS_((
Tcl_Parse *parsePtr));
MODULE_SCOPE int TclFileAttrsCmd _ANSI_ARGS_((Tcl_Interp *interp,
@@ -1871,6 +1875,7 @@ MODULE_SCOPE int TclFileRenameCmd _ANSI_ARGS_((Tcl_Interp *interp,
MODULE_SCOPE void TclFinalizeAllocSubsystem _ANSI_ARGS_((void));
MODULE_SCOPE void TclFinalizeCompExecEnv _ANSI_ARGS_((void));
MODULE_SCOPE void TclFinalizeCompilation _ANSI_ARGS_((void));
+MODULE_SCOPE void TclFinalizeDoubleConversion _ANSI_ARGS_((void));
MODULE_SCOPE void TclFinalizeEncodingSubsystem _ANSI_ARGS_((void));
MODULE_SCOPE void TclFinalizeEnvironment _ANSI_ARGS_((void));
MODULE_SCOPE void TclFinalizeExecution _ANSI_ARGS_((void));
@@ -1884,6 +1889,7 @@ MODULE_SCOPE void TclFinalizeAsync _ANSI_ARGS_((void));
MODULE_SCOPE void TclFinalizeSynchronization _ANSI_ARGS_((void));
MODULE_SCOPE void TclFinalizeLock _ANSI_ARGS_((void));
MODULE_SCOPE void TclFinalizeThreadData _ANSI_ARGS_((void));
+MODULE_SCOPE void TclFormatNaN _ANSI_ARGS_((double value, char* buffer));
MODULE_SCOPE int TclFSFileAttrIndex _ANSI_ARGS_((Tcl_Obj *pathPtr,
CONST char *attributeName, int *indexPtr));
MODULE_SCOPE Tcl_Obj * TclGetBgErrorHandler _ANSI_ARGS_((Tcl_Interp *interp));
@@ -1902,6 +1908,7 @@ MODULE_SCOPE int TclGlob _ANSI_ARGS_((Tcl_Interp *interp,
int globFlags, Tcl_GlobTypeData* types));
MODULE_SCOPE void TclInitAlloc _ANSI_ARGS_((void));
MODULE_SCOPE void TclInitDbCkalloc _ANSI_ARGS_((void));
+MODULE_SCOPE void TclInitDoubleConversion _ANSI_ARGS_((void));
MODULE_SCOPE void TclInitEmbeddedConfigurationInformation
_ANSI_ARGS_((Tcl_Interp *interp));
MODULE_SCOPE void TclInitEncodingSubsystem _ANSI_ARGS_((void));
@@ -2048,6 +2055,8 @@ MODULE_SCOPE void TclSetProcessGlobalValue _ANSI_ARGS_ ((
Tcl_Encoding encoding));
MODULE_SCOPE VOID TclSignalExitThread _ANSI_ARGS_((Tcl_ThreadId id,
int result));
+MODULE_SCOPE double TclStrToD _ANSI_ARGS_((CONST char* string,
+ CONST char** endPtr));
MODULE_SCOPE int TclSubstTokens _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Token *tokenPtr, int count,
int *tokensLeftPtr));
@@ -2717,6 +2726,20 @@ MODULE_SCOPE void TclDbInitNewObj _ANSI_ARGS_((Tcl_Obj *objPtr));
}
/*
+ *----------------------------------------------------------------------
+ *
+ * Core procedures added to libtommath for bignum manipulation.
+ *
+ *----------------------------------------------------------------------
+ */
+
+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 );
+
+
+/*
*----------------------------------------------------------------
* Macro used by the Tcl core to check whether a pattern has
* any characters special to [string match].
diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h
index 6972a28..7364d0f 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.78 2005/05/05 18:38:02 dgp Exp $
+ * RCS: @(#) $Id: tclIntDecls.h,v 1.79 2005/05/10 18:34:42 kennykb Exp $
*/
#ifndef _TCLINTDECLS
@@ -1128,6 +1128,34 @@ EXTERN int TclPushStackFrame _ANSI_ARGS_((Tcl_Interp * interp,
/* 218 */
EXTERN void TclPopStackFrame _ANSI_ARGS_((Tcl_Interp * interp));
#endif
+#ifndef TclBN_mp_div_d_TCL_DECLARED
+#define TclBN_mp_div_d_TCL_DECLARED
+/* 219 */
+EXTERN int TclBN_mp_div_d _ANSI_ARGS_((mp_int * a, mp_digit b,
+ mp_int * c, mp_digit * d));
+#endif
+#ifndef TclBN_mp_mul_d_TCL_DECLARED
+#define TclBN_mp_mul_d_TCL_DECLARED
+/* 220 */
+EXTERN int TclBN_mp_mul_d _ANSI_ARGS_((mp_int * a, mp_digit b,
+ mp_int * c));
+#endif
+#ifndef TclBN_mp_clear_TCL_DECLARED
+#define TclBN_mp_clear_TCL_DECLARED
+/* 221 */
+EXTERN void TclBN_mp_clear _ANSI_ARGS_((mp_int * a));
+#endif
+#ifndef TclBN_mp_init_TCL_DECLARED
+#define TclBN_mp_init_TCL_DECLARED
+/* 222 */
+EXTERN int TclBN_mp_init _ANSI_ARGS_((mp_int * a));
+#endif
+#ifndef TclBN_mp_read_radix_TCL_DECLARED
+#define TclBN_mp_read_radix_TCL_DECLARED
+/* 223 */
+EXTERN int TclBN_mp_read_radix _ANSI_ARGS_((mp_int * a,
+ const char * str, int radix));
+#endif
typedef struct TclIntStubs {
int magic;
@@ -1367,6 +1395,11 @@ typedef struct TclIntStubs {
void (*tclStackFree) _ANSI_ARGS_((Tcl_Interp * interp)); /* 216 */
int (*tclPushStackFrame) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_CallFrame ** framePtrPtr, Tcl_Namespace * namespacePtr, int isProcCallFrame)); /* 217 */
void (*tclPopStackFrame) _ANSI_ARGS_((Tcl_Interp * interp)); /* 218 */
+ int (*tclBN_mp_div_d) _ANSI_ARGS_((mp_int * a, mp_digit b, mp_int * c, mp_digit * d)); /* 219 */
+ int (*tclBN_mp_mul_d) _ANSI_ARGS_((mp_int * a, mp_digit b, mp_int * c)); /* 220 */
+ void (*tclBN_mp_clear) _ANSI_ARGS_((mp_int * a)); /* 221 */
+ int (*tclBN_mp_init) _ANSI_ARGS_((mp_int * a)); /* 222 */
+ int (*tclBN_mp_read_radix) _ANSI_ARGS_((mp_int * a, const char * str, int radix)); /* 223 */
} TclIntStubs;
#ifdef __cplusplus
@@ -2121,6 +2154,26 @@ extern TclIntStubs *tclIntStubsPtr;
#define TclPopStackFrame \
(tclIntStubsPtr->tclPopStackFrame) /* 218 */
#endif
+#ifndef TclBN_mp_div_d
+#define TclBN_mp_div_d \
+ (tclIntStubsPtr->tclBN_mp_div_d) /* 219 */
+#endif
+#ifndef TclBN_mp_mul_d
+#define TclBN_mp_mul_d \
+ (tclIntStubsPtr->tclBN_mp_mul_d) /* 220 */
+#endif
+#ifndef TclBN_mp_clear
+#define TclBN_mp_clear \
+ (tclIntStubsPtr->tclBN_mp_clear) /* 221 */
+#endif
+#ifndef TclBN_mp_init
+#define TclBN_mp_init \
+ (tclIntStubsPtr->tclBN_mp_init) /* 222 */
+#endif
+#ifndef TclBN_mp_read_radix
+#define TclBN_mp_read_radix \
+ (tclIntStubsPtr->tclBN_mp_read_radix) /* 223 */
+#endif
#endif /* defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) */
diff --git a/generic/tclInterp.c b/generic/tclInterp.c
index 74d4006..f6cc8dc 100644
--- a/generic/tclInterp.c
+++ b/generic/tclInterp.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: tclInterp.c,v 1.58 2005/04/19 16:32:56 dgp Exp $
+ * RCS: @(#) $Id: tclInterp.c,v 1.59 2005/05/10 18:34:44 kennykb Exp $
*/
#include "tclInt.h"
diff --git a/generic/tclListObj.c b/generic/tclListObj.c
index 47bcccf..aa793f4 100644
--- a/generic/tclListObj.c
+++ b/generic/tclListObj.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: tclListObj.c,v 1.22 2005/04/09 11:09:58 das Exp $
+ * RCS: @(#) $Id: tclListObj.c,v 1.23 2005/05/10 18:34:44 kennykb Exp $
*/
#include "tclInt.h"
diff --git a/generic/tclLiteral.c b/generic/tclLiteral.c
index e55814e..962856e 100644
--- a/generic/tclLiteral.c
+++ b/generic/tclLiteral.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: tclLiteral.c,v 1.23 2005/04/25 02:08:33 dgp Exp $
+ * RCS: @(#) $Id: tclLiteral.c,v 1.24 2005/05/10 18:34:44 kennykb Exp $
*/
#include "tclInt.h"
diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c
index 5cd013e..27f5603 100644
--- a/generic/tclNamesp.c
+++ b/generic/tclNamesp.c
@@ -21,7 +21,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclNamesp.c,v 1.73 2005/05/05 18:38:04 dgp Exp $
+ * RCS: @(#) $Id: tclNamesp.c,v 1.74 2005/05/10 18:34:45 kennykb Exp $
*/
#include "tclInt.h"
diff --git a/generic/tclNotify.c b/generic/tclNotify.c
index 4a343aa..d025c2c 100644
--- a/generic/tclNotify.c
+++ b/generic/tclNotify.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: tclNotify.c,v 1.17 2005/04/26 00:45:01 das Exp $
+ * RCS: @(#) $Id: tclNotify.c,v 1.18 2005/05/10 18:34:46 kennykb Exp $
*/
#include "tclInt.h"
diff --git a/generic/tclObj.c b/generic/tclObj.c
index 1b25e16..5f5cfb2 100644
--- a/generic/tclObj.c
+++ b/generic/tclObj.c
@@ -7,15 +7,28 @@
* Copyright (c) 1995-1997 Sun Microsystems, Inc.
* Copyright (c) 1999 by Scriptics Corporation.
* Copyright (c) 2001 by ActiveState Corporation.
+ * 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: tclObj.c,v 1.82 2005/04/25 02:08:34 dgp Exp $
+ * RCS: @(#) $Id: tclObj.c,v 1.83 2005/05/10 18:34:46 kennykb Exp $
*/
#include "tclInt.h"
+#include "tommath.h"
#include "tclCompile.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
/*
* Table of all object types.
@@ -136,6 +149,28 @@ Tcl_ThreadDataKey pendingObjDataKey;
/*
+ * Macros to pack/unpack a bignum's fields in a Tcl_Obj internal rep
+ */
+
+#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 )
+
+#define UNPACK_BIGNUM( objPtr, bignum ) \
+ do { \
+ (bignum).dp = (mp_digit*) (objPtr)->internalRep.bignumValue.digits; \
+ (bignum).sign = (objPtr)->internalRep.bignumValue.misc >> 30; \
+ (bignum).alloc = ( (objPtr)->internalRep.bignumValue.misc >> 15 ) \
+ & 0x7fff; \
+ (bignum).used = (objPtr)->internalRep.bignumValue.misc & 0x7fff; \
+ } while ( 0 )
+
+/*
* Prototypes for procedures defined later in this file:
*/
@@ -157,6 +192,13 @@ static int SetWideIntFromAny _ANSI_ARGS_((Tcl_Interp *interp,
static void UpdateStringOfWideInt _ANSI_ARGS_((Tcl_Obj *objPtr));
#endif
+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 ));
+
/*
* Prototypes for the array hash key methods.
*/
@@ -226,6 +268,14 @@ Tcl_ObjType tclWideIntType = {
SetWideIntFromAny /* setFromAnyProc */
};
+Tcl_ObjType tclBignumType = {
+ "bignum", /* name */
+ FreeBignum, /* freeIntRepProc */
+ DupBignum, /* dupIntRepProc */
+ UpdateStringOfBignum, /* updateStringProc */
+ SetBignumFromAny /* setFromAnyProc */
+};
+
/*
* The structure below defines the Tcl obj hash key type.
*/
@@ -331,6 +381,7 @@ TclInitObjSubsystem()
Tcl_RegisterObjType(&tclEndOffsetType);
Tcl_RegisterObjType(&tclIntType);
Tcl_RegisterObjType(&tclWideIntType);
+ Tcl_RegisterObjType( &tclBignumType );
Tcl_RegisterObjType(&tclStringType);
Tcl_RegisterObjType(&tclListType);
Tcl_RegisterObjType(&tclDictType);
@@ -1670,22 +1721,29 @@ Tcl_GetDoubleFromObj(interp, objPtr, dblPtr)
{
register int result;
- if (objPtr->typePtr == &tclDoubleType) {
- *dblPtr = objPtr->internalRep.doubleValue;
- return TCL_OK;
- } else if (objPtr->typePtr == &tclIntType) {
+ 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;
+ }
}
-
- result = SetDoubleFromAny(interp, objPtr);
- if (result == TCL_OK) {
- *dblPtr = objPtr->internalRep.doubleValue;
+ if ( IS_NAN( objPtr->internalRep.doubleValue ) ) {
+ if ( interp != NULL ) {
+ Tcl_SetObjResult
+ ( interp,
+ Tcl_NewStringObj( "floating point value is Not a Number",
+ -1 ) );
+ }
+ return TCL_ERROR;
}
- return result;
+ *dblPtr = objPtr->internalRep.doubleValue;
+ return TCL_OK;
}
/*
@@ -1713,7 +1771,7 @@ SetDoubleFromAny(interp, objPtr)
Tcl_Interp *interp; /* Used for error reporting if not NULL. */
register Tcl_Obj *objPtr; /* The object to convert. */
{
- char *string, *end;
+ CONST char *string, *end;
double newDouble;
int length;
@@ -1730,7 +1788,7 @@ SetDoubleFromAny(interp, objPtr)
*/
errno = 0;
- newDouble = strtod(string, &end);
+ newDouble = TclStrToD(string, &end);
if (end == string) {
badDouble:
if (interp != NULL) {
@@ -1755,7 +1813,7 @@ SetDoubleFromAny(interp, objPtr)
goto badDouble;
}
- if (errno != 0) {
+ if (errno != 0 && errno != ERANGE) {
if (interp != NULL) {
TclExprFloatError(interp, newDouble);
}
@@ -2715,6 +2773,390 @@ Tcl_GetWideIntFromObj(interp, objPtr, wideIntPtr)
/*
*----------------------------------------------------------------------
*
+ * FreeBignum --
+ *
+ * This procedure frees the internal rep of a bignum.
+ *
+ * Results:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+FreeBignum( Tcl_Obj* objPtr )
+{
+ mp_int toFree; /* Bignum to free */
+ UNPACK_BIGNUM( objPtr, toFree );
+ mp_clear( &toFree );
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * DupBignum --
+ *
+ * This procedure duplicates the internal rep of a bignum.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * The destination object receies a copy of the source object
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+DupBignum( srcPtr, copyPtr )
+ Tcl_Obj* srcPtr;
+ Tcl_Obj* copyPtr;
+{
+ mp_int bignumVal;
+ mp_int bignumCopy;
+ copyPtr->typePtr = &tclBignumType;
+ UNPACK_BIGNUM( srcPtr, bignumVal );
+ 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;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * UpdateStringOfBignum --
+ *
+ * This procedure updates the string representation of a bignum
+ * object.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * The object's string is set to whatever results from the bignum-
+ * to-string conversion.
+ *
+ * The object's existing string representation is NOT freed; memory
+ * will leak if the string rep is still valid at the time this procedure
+ * is called.
+ */
+
+void
+UpdateStringOfBignum( Tcl_Obj* objPtr )
+{
+ mp_int bignumVal;
+ int size;
+ int status;
+ char* stringVal;
+ UNPACK_BIGNUM( objPtr, bignumVal );
+ status = mp_radix_size( &bignumVal, 10, &size );
+ if ( status != MP_OKAY ) {
+ Tcl_Panic( "radix size failure in UpdateStringOfBignum" );
+ }
+ stringVal = Tcl_Alloc( (size_t) size );
+ status = mp_toradix_n( &bignumVal, stringVal, 10, size );
+ if ( status != MP_OKAY ) {
+ Tcl_Panic( "conversion failure in UpdateStringOfBignum" );
+ }
+ objPtr->bytes = stringVal;
+ objPtr->length = size - 1; /* size includes a trailing null byte */
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_NewBignumObj --
+ *
+ * Creates an initializes a bignum object.
+ *
+ * Results:
+ * Returns the newly created object.
+ *
+ * Side effects:
+ * The bignum value is cleared, since ownership has transferred
+ * to Tcl.
+ *
+ *----------------------------------------------------------------------
+ */
+
+#ifdef TCL_MEM_DEBUG
+#undef Tcl_NewBignumObj
+Tcl_Obj*
+Tcl_NewBignumObj( mp_int* bignumValue )
+{
+ return Tcl_DbNewBignumObj( bignumValue, "unknown", 0 );
+}
+#else
+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 );
+
+ return objPtr;
+}
+#endif
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_DbNewBignumObj --
+ *
+ * This procedure is normally called when debugging: that is, when
+ * TCL_MEM_DEBUG is defined. It constructs a bignum object, recording
+ * the creation point so that [memory active] can report it.
+ *
+ * Results:
+ * Returns the newly created object.
+ *
+ * Side effects:
+ * The bignum value is cleared, since ownership has transferred
+ * to Tcl.
+ *
+ *----------------------------------------------------------------------
+ */
+
+#ifdef TCL_MEM_DEBUG
+Tcl_Obj*
+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 );
+
+ return objPtr;
+}
+#else
+Tcl_Obj*
+Tcl_DbNewBignumObj( mp_int* bignumValue, CONST char* file, int line )
+{
+ return Tcl_NewBignumObj( bignumValue );
+}
+#endif
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_GetBignumFromObj --
+ *
+ * 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. The raw value of the object is
+ * returned, and Tcl owns that memory, so the caller should NOT invoke
+ * mp_clear afterwards.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_GetBignumFromObj( Tcl_Interp* interp,
+ /* Tcl interpreter for error reporting */
+ Tcl_Obj* objPtr,
+ /* Object to read */
+ mp_int* bignumValue )
+ /* Returned bignum value. */
+{
+ mp_int temp;
+ 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;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_SetBignumObj --
+ *
+ * This procedure sets the value of a Tcl_Obj to a large integer.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Object value is stored. The bignum value is cleared, since
+ * ownership has transferred to Tcl.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+Tcl_SetBignumObj( Tcl_Obj* objPtr,
+ /* Object to set */
+ mp_int* bignumValue )
+ /* Value to store */
+{
+ if ( Tcl_IsShared( objPtr ) ) {
+ Tcl_Panic( "Tcl_SetBignumObj called with shared object" );
+ }
+ TclFreeIntRep( objPtr );
+ objPtr->typePtr = &tclBignumType;
+ PACK_BIGNUM( *bignumValue, objPtr );
+ Tcl_InvalidateStringRep( objPtr );
+
+ /* Clear the value with mp_init; mp_clear overwrites the digit array. */
+
+ mp_init( bignumValue );
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* Tcl_DbIncrRefCount --
*
* This procedure is normally called when debugging: i.e., when
diff --git a/generic/tclParse.c b/generic/tclParse.c
index 9700f93..fbf1d65 100644
--- a/generic/tclParse.c
+++ b/generic/tclParse.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: tclParse.c,v 1.41 2005/05/03 18:08:18 dgp Exp $
+ * RCS: @(#) $Id: tclParse.c,v 1.42 2005/05/10 18:34:46 kennykb Exp $
*/
#include "tclInt.h"
diff --git a/generic/tclParseExpr.c b/generic/tclParseExpr.c
index 61860f6..c6a478e 100644
--- a/generic/tclParseExpr.c
+++ b/generic/tclParseExpr.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: tclParseExpr.c,v 1.24 2005/05/03 18:08:19 dgp Exp $
+ * RCS: @(#) $Id: tclParseExpr.c,v 1.25 2005/05/10 18:34:47 kennykb Exp $
*/
#include "tclInt.h"
@@ -1451,43 +1451,32 @@ ParsePrimaryExpr(infoPtr)
return code;
}
if (infoPtr->lexeme != OPEN_PAREN) {
- /*
- * Guess what kind of error we have by trying to tell
- * whether we have a function or variable name here.
- * Alas, this makes the parser more tightly bound with the
- * rest of the interpreter, but that is the only way to
- * give a sensible message here. Still, it is not too
- * serious as this is only done when generating an error.
- */
- Interp *iPtr = (Interp *) infoPtr->parsePtr->interp;
- Tcl_DString functionName;
- Tcl_HashEntry *hPtr;
/*
- * Look up the name as a function name. We need a writable
- * copy (DString) so we can terminate it with a NULL for
- * the benefit of Tcl_FindHashEntry which operates on
- * NULL-terminated string keys.
+ * Either there's a math function without a (, or a
+ * variable name without a '$'.
*/
- Tcl_DStringInit(&functionName);
- hPtr = Tcl_FindHashEntry(&iPtr->mathFuncTable,
- Tcl_DStringAppend(&functionName, tokenPtr->start,
- tokenPtr->size));
- Tcl_DStringFree(&functionName);
- /*
- * Assume that we have an attempted variable reference
- * unless we've got a function name, as the set of
- * potential function names is typically much smaller.
- */
- if (hPtr != NULL) {
- LogSyntaxError(infoPtr,
- "expected parenthesis enclosing function arguments");
- } else {
- LogSyntaxError(infoPtr,
- "variable references require preceding $");
- }
+ Tcl_Obj* errMsg
+ = Tcl_NewStringObj( "syntax error in expression \"", -1 );
+ TclAppendLimitedToObj( errMsg,
+ infoPtr->originalExpr,
+ (int) (infoPtr->lastChar
+ - infoPtr->originalExpr ),
+ 63,
+ NULL );
+ Tcl_AppendToObj( errMsg, "\": the word \"", -1 );
+ Tcl_AppendToObj( errMsg, tokenPtr->start, tokenPtr->size );
+ Tcl_AppendToObj( errMsg,
+ "\" requires a preceding $ if it's a variable ",
+ -1 );
+ Tcl_AppendToObj( errMsg,
+ "or function arguments if it's a function", -1 );
+ Tcl_SetObjResult( infoPtr->parsePtr->interp, errMsg );
+ infoPtr->parsePtr->errorType = TCL_PARSE_SYNTAX;
+ infoPtr->parsePtr->term = infoPtr->start;
return TCL_ERROR;
+
}
code = GetLexeme(infoPtr); /* skip over '(' */
if (code != TCL_OK) {
@@ -1666,23 +1655,17 @@ GetLexeme(infoPtr)
* so we can set an terminating NULL to keep strtod from
* scanning too far.
*/
- char *startPtr, *termPtr;
+ char *startPtr;
+ CONST char *termPtr;
double doubleValue;
Tcl_DString toParse;
errno = 0;
Tcl_DStringInit(&toParse);
startPtr = Tcl_DStringAppend(&toParse, src, length);
- doubleValue = strtod(startPtr, &termPtr);
+ doubleValue = TclStrToD(startPtr, &termPtr);
Tcl_DStringFree(&toParse);
if (termPtr != startPtr) {
- if (errno != 0) {
- if (interp != NULL) {
- TclExprFloatError(interp, doubleValue);
- }
- parsePtr->errorType = TCL_PARSE_BAD_NUMBER;
- return TCL_ERROR;
- }
/*
* startPtr was the start of a valid double, copied
@@ -2077,7 +2060,7 @@ ParseMaxDoubleLength(string, end)
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 '-': case '(': case ' ': case ')':
p++;
break;
default:
diff --git a/generic/tclPathObj.c b/generic/tclPathObj.c
index 5a57477..08491cc 100644
--- a/generic/tclPathObj.c
+++ b/generic/tclPathObj.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: tclPathObj.c,v 1.40 2005/02/05 09:15:42 davidw Exp $
+ * RCS: @(#) $Id: tclPathObj.c,v 1.41 2005/05/10 18:34:47 kennykb Exp $
*/
#include "tclInt.h"
diff --git a/generic/tclPort.h b/generic/tclPort.h
index 730ab76..ad98823 100644
--- a/generic/tclPort.h
+++ b/generic/tclPort.h
@@ -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: tclPort.h,v 1.14 2005/01/05 10:31:02 dkf Exp $
+ * RCS: @(#) $Id: tclPort.h,v 1.15 2005/05/10 18:34:47 kennykb Exp $
*/
#ifndef _TCLPORT
diff --git a/generic/tclProc.c b/generic/tclProc.c
index 4d9e7e0..a87caa7 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.73 2005/02/02 23:09:06 mdejong Exp $
+ * RCS: @(#) $Id: tclProc.c,v 1.74 2005/05/10 18:34:47 kennykb Exp $
*/
#include "tclInt.h"
diff --git a/generic/tclRegexp.c b/generic/tclRegexp.c
index 25c30dc..dfc7236 100644
--- a/generic/tclRegexp.c
+++ b/generic/tclRegexp.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: tclRegexp.c,v 1.18 2005/05/03 18:08:19 dgp Exp $
+ * RCS: @(#) $Id: tclRegexp.c,v 1.19 2005/05/10 18:34:48 kennykb Exp $
*/
#include "tclInt.h"
diff --git a/generic/tclResult.c b/generic/tclResult.c
index bf00083..770d7cb 100644
--- a/generic/tclResult.c
+++ b/generic/tclResult.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: tclResult.c,v 1.24 2005/05/03 18:08:20 dgp Exp $
+ * RCS: @(#) $Id: tclResult.c,v 1.25 2005/05/10 18:34:48 kennykb Exp $
*/
#include "tclInt.h"
diff --git a/generic/tclScan.c b/generic/tclScan.c
index 624910c..2e4bf18 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.16 2004/10/06 15:59:25 dgp Exp $
+ * RCS: @(#) $Id: tclScan.c,v 1.17 2005/05/10 18:34:49 kennykb Exp $
*/
#include "tclInt.h"
@@ -1144,7 +1144,7 @@ Tcl_ScanObjCmd(dummy, interp, objc, objv)
if (!(flags & SCAN_SUPPRESS)) {
double dvalue;
*end = '\0';
- dvalue = strtod(buf, NULL);
+ dvalue = TclStrToD(buf, NULL);
objPtr = Tcl_NewDoubleObj(dvalue);
Tcl_IncrRefCount(objPtr);
objs[objIndex++] = objPtr;
diff --git a/generic/tclStrToD.c b/generic/tclStrToD.c
new file mode 100755
index 0000000..2d622a7
--- /dev/null
+++ b/generic/tclStrToD.c
@@ -0,0 +1,1361 @@
+/*
+ *----------------------------------------------------------------------
+ *
+ * tclStrToD.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.
+ *
+ * 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.2 2005/05/10 18:34:49 kennykb Exp $
+ *
+ *----------------------------------------------------------------------
+ */
+
+#include <tclInt.h>
+#include <stdio.h>
+#include <stdlib.h>
+#include <float.h>
+#include <limits.h>
+#include <math.h>
+#include <ctype.h>
+#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.
+ */
+
+#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
+
+#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.
+ */
+
+#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))
+#endif
+
+/* 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'. */
+
+/* Inexact higher powers of ten */
+
+static CONST double pow_10_2_n [] = {
+ 1.0,
+ 100.0,
+ 10000.0,
+ 1.0e+8,
+ 1.0e+16,
+ 1.0e+32,
+ 1.0e+64,
+ 1.0e+128,
+ 1.0e+256
+};
+
+/* 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 _ANSI_ARGS_((double approx, CONST char* start,
+ int nDigits, long exponent));
+static double ParseNaN _ANSI_ARGS_(( int signum, CONST char** end ));
+static double SafeLdExp _ANSI_ARGS_(( double fraction, int exponent ));
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclStrToD --
+ *
+ * Scans a double from a string.
+ *
+ * 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.
+ *
+ * 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.
+ *
+ *------------------------------------------------------------------------
+ */
+
+double
+TclStrToD( CONST char* s,
+ /* String to scan */
+ CONST char ** endPtr )
+ /* Pointer to the end of the scanned number */
+{
+
+ 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 */
+
+ /*
+ * v must be 'volatile double' on gc-ix86 to force correct rounding
+ * to IEEE double and not Intel double-extended.
+ */
+
+ volatile double v; /* Scanned value */
+ 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
+ * 1 ulp, so we need to change rounding mode to 53-bits.
+ */
+
+#if defined(__GNUC__) && defined(__i386)
+ fpu_control_t roundTo53Bits = 0x027f;
+ fpu_control_t oldRoundingMode;
+ _FPU_GETCW( oldRoundingMode );
+ _FPU_SETCW( roundTo53Bits );
+#endif
+
+ /* Discard leading whitespace */
+
+ while ( isspace( *p ) ) {
+ ++p;
+ }
+
+ /* Determine the sign of the significand */
+
+ switch( *p ) {
+ case '-':
+ signum = 1;
+ /* FALLTHROUGH */
+ case '+':
+ ++p;
+ }
+
+ /* Discard leading zeroes */
+
+ while ( *p == '0' ) {
+ seenDigit = 1;
+ ++p;
+ }
+
+ /*
+ * 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.
+ */
+
+ for ( ; ; ) {
+ c = *p;
+ if ( c == '.' && !seenDp ) {
+ seenDp = 1;
+ ++p;
+ } else if ( isdigit(c) ) {
+ if ( c == '0' ) {
+ if ( startOfSignificand != NULL ) {
+ ++nTrailZero;
+ }
+ } 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 ];
+ }
+ nSigDigs += nTrailZero;
+ }
+ if ( nSigDigs < DBL_DIG ) {
+ exactSignificand = 10. * exactSignificand + (c - '0');
+ }
+ ++nSigDigs;
+ nTrailZero = 0;
+ }
+ if ( seenDp ) {
+ ++nDigitsAfterDp;
+ }
+ seenDigit = 1;
+ ++p;
+ } else {
+ break;
+ }
+ }
+
+ /*
+ * 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
+ */
+
+ exponent = 0;
+ if ( seenDigit && ( *p == 'e' || *p == 'E' ) ) {
+ CONST char* stringSave = p;
+ ++p;
+ c = *p;
+ if ( isdigit( c ) || c == '+' || c == '-' ) {
+ errno = 0;
+ exponent = strtol( p, (char**)&p, 10 );
+ if ( errno == ERANGE ) {
+ if ( exponent > 0 ) {
+ v = HUGE_VAL;
+ } else {
+ v = 0.0;
+ }
+ *endPtr = p;
+ goto returnValue;
+ }
+ }
+ if ( p == stringSave + 1 ) {
+ p = stringSave;
+ exponent = 0;
+ }
+ }
+ exponent = exponent + nTrailZero - nDigitsAfterDp;
+
+ /*
+ * If we come here with no significant digits, we might still be
+ * looking at Inf or NaN. Go parse them.
+ */
+
+ if ( !seenDigit ) {
+
+ /* Test for Inf */
+
+ 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;
+ }
+ goto returnValue;
+ }
+
+
+#ifdef IEEE_FLOATING_POINT
+
+ /* IEEE floating point supports NaN */
+
+ } 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;
+ }
+
+ /* Restore FPU mode word */
+
+#if defined(__GNUC__) && defined(__i386)
+ _FPU_SETCW( oldRoundingMode );
+#endif
+ return ParseNaN( signum, endPtr );
+
+ }
+#endif
+
+ }
+
+ goto error;
+ }
+
+ /*
+ * We've successfully scanned; update the end-of-element pointer.
+ */
+
+ if ( endPtr != NULL ) {
+ *endPtr = p;
+ }
+
+ /* Test for zero. */
+
+ if ( nSigDigs == 0 ) {
+ v = 0.0;
+ goto returnValue;
+ }
+
+ /*
+ * 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.
+ */
+
+ 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;
+ }
+ }
+ } else {
+ if ( exponent >= -mmaxpow ) {
+ v = exactSignificand / pow10[ -exponent ];
+ goto returnValue;
+ }
+ }
+ }
+
+ /*
+ * 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.
+ */
+
+ if ( nSigDigs + exponent - 1 > maxDigits ) {
+ v = HUGE_VAL;
+ errno = ERANGE;
+ goto returnValue;
+ }
+ if ( nSigDigs + exponent - 1 < minDigits ) {
+ errno = ERANGE;
+ v = 0.;
+ goto returnValue;
+ }
+
+ /*
+ * 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;
+ }
+ }
+ } 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;
+ }
+ }
+ }
+
+ /*
+ * 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.
+ */
+
+ if ( machexp > DBL_MAX_EXP * log2FLT_RADIX ) {
+ v = HUGE_VAL;
+ errno = ERANGE;
+ goto returnValue;
+ }
+
+ v = SafeLdExp( v, machexp );
+ if ( v < tiny ) {
+ v = tiny;
+ }
+
+ /* We have a first approximation in v. Now we need to refine it. */
+
+ v = RefineResult( v, startOfSignificand, nSigDigs, exponent );
+
+ /* In a very few cases, a second iteration is needed. e.g., 457e-102 */
+
+ v = RefineResult( v, startOfSignificand, nSigDigs, exponent );
+
+ /* Handle underflow */
+
+ returnValue:
+ if ( nSigDigs != 0 && v == 0.0 ) {
+ errno = ERANGE;
+ }
+
+ /* Return a number with correct sign */
+
+ if ( signum ) {
+ v = -v;
+ }
+
+ /* Restore FPU mode word */
+
+#if defined(__GNUC__) && defined(__i386)
+ _FPU_SETCW( oldRoundingMode );
+#endif
+
+ return v;
+
+ /* Come here on an invalid input */
+
+ error:
+ if ( endPtr != NULL ) {
+ *endPtr = s;
+ }
+
+ /* Restore FPU mode word */
+
+#if defined(__GNUC__) && defined(__i386)
+ _FPU_SETCW( oldRoundingMode );
+#endif
+ return 0.0;
+
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * RefineResult --
+ *
+ * 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.
+ *
+ *----------------------------------------------------------------------
+ */
+
+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 */
+{
+
+ 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 */
+ 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. */
+ int i;
+ CONST char* p;
+
+ /*
+ * The first approximation is always low. If we find that
+ * it's HUGE_VAL, we're done.
+ */
+
+ 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.
+ */
+
+ significand = frexp( approxResult, &binExponent );
+ i = mantBits - binExponent;
+ if ( i < 0 ) {
+ M2 = 0;
+ } else {
+ M2 = i;
+ }
+ if ( exponent > 0 ) {
+ M5 = 0;
+ } else {
+ M5 = -exponent;
+ 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
+ * appropriately. Then multiply by the appropriate power of 5.
+ */
+
+ msb = binExponent + M2; /* 1008 */
+ nDigits = 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 ) {
+ twoMv.dp[nDigits] = (mp_digit) significand;
+ significand -= (mp_digit) significand;
+ significand = SafeLdExp( significand, DIGIT_BIT );
+ }
+ 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).
+ */
+
+ mp_init( &twoMd ); mp_zero( &twoMd );
+ i = nSigDigs;
+ for ( p = sigStart ; ; ++p ) {
+ char c = *p;
+ if ( isdigit( 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_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
+ * term. Because 2M may well overflow a double, we need to scale the
+ * denominator by a factor of 2**binExponent-mantBits
+ */
+
+ scale = binExponent - mantBits - 1;
+
+ 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 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 ) {
+ return approxResult;
+ }
+
+ /*
+ * Convert the numerator and denominator of the corrector term
+ * accurately to floating point numbers.
+ */
+
+ num = TclBignumToDouble( &twoMd );
+ den = TclBignumToDouble( &twoMv );
+
+ quot = SafeLdExp( num/den, scale );
+ minincr = SafeLdExp( 1.0, binExponent - mantBits );
+
+ if ( quot < 0. && quot > -minincr ) {
+ quot = -minincr;
+ } else if ( quot > 0. && quot < minincr ) {
+ quot = minincr;
+ }
+
+ 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.
+ *
+ *----------------------------------------------------------------------
+ */
+
+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(c) ) {
+ continue;
+ } else if ( c == ')' ) {
+ *endPtr = p;
+ break;
+ } else if ( isdigit(c) ) {
+ c -= '0';
+ } else if ( c >= 'A' && c <= 'F' ) {
+ c = c - 'A' + 10;
+ } else if ( c >= 'a' && c <= 'f' ) {
+ c = c - 'a' + 10;
+ } else {
+ theNaN.iv = ( ((Tcl_WideUInt) 0x7ff8) << 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) 0x7ff8) << 48;
+ }
+
+ *endPtr = p;
+ return theNaN.dv;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclDoubleDigits --
+ *
+ * Converts a double to a string of digits.
+ *
+ * Results:
+ * Returns the position of the character in the string
+ * after which the decimal point should appear. Since
+ * the string contains only significant digits, the
+ * position may be less than zero or greater than the
+ * length of the string.
+ *
+ * Side effects:
+ * Stores the digits in the given buffer and sets 'signum'
+ * according to the sign of the number.
+ *
+ *----------------------------------------------------------------------
+ */
+
+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. */
+{
+
+ double f; /* Significand of v */
+
+ int e; /* Power of FLT_RADIX that satisfies
+ * v = f * FLT_RADIX**e */
+
+
+ int low_ok;
+ int high_ok;
+
+ mp_int r; /* Scaled significand */
+ mp_int s; /* Divisor such that v = r / s */
+ mp_int mplus; /* Scaled epsilon: (r + 2* mplus) ==
+ * v(+) where v(+) is the floating point
+ * successor of v. */
+ mp_int mminus; /* Scaled epsilon: (r - 2*mminus ) ==
+ * v(-) where v(-) is the floating point
+ * predecessor of v. */
+ mp_int temp;
+
+ int rfac2 = 0; /* Powers of 2 and 5 by which large */
+ int rfac5 = 0; /* integers should be scaled */
+ int sfac2 = 0;
+ 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.)
+ */
+
+#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
+
+ /* Handle zero specially */
+
+ if ( v == 0.0 ) {
+ *strPtr++ = '0';
+ *strPtr++ = '\0';
+ return 1;
+ }
+
+ /*
+ * Develop f and e such that v = f * FLT_RADIX**e, with
+ * 1.0/FLT_RADIX <= f < 1.
+ */
+
+ 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;
+
+ low_ok = high_ok = ( mp_iseven( &r ) );
+
+ /*
+ * We are going to want to develop integers r, s, mplus, and mminus
+ * such that v = r / s, v(+)-v / 2 = mplus / s; v-v(-) / 2 = mminus / s
+ * and then scale either s or r, mplus, mminus by an appropriate
+ * power of ten.
+ *
+ * We actually do this by keeping track of the powers of 2 and 5
+ * by which f is multiplied to yield v and by which 1 is multiplied
+ * to yield s, mplus, and mminus.
+ */
+
+ if ( e >= 0 ) {
+
+ int bits = e * log2FLT_RADIX;
+
+ if ( f != 1.0 / FLT_RADIX ) {
+
+ /* Normal case, m+ and m- are both FLT_RADIX**e */
+
+ rfac2 += bits + 1;
+ sfac2 = 1;
+ mplusfac2 = bits;
+ mminusfac2 = bits;
+
+ } else {
+
+ /*
+ * If f is equal to the smallest significand, then we need another
+ * factor of FLT_RADIX in s to cope with stepping to
+ * the next smaller exponent when going to e's predecessor.
+ */
+
+ rfac2 += bits + log2FLT_RADIX - 1;
+ sfac2 = 1 + log2FLT_RADIX;
+ mplusfac2 = bits + log2FLT_RADIX;
+ mminusfac2 = bits;
+
+ }
+
+ } else {
+
+ /* v has digits after the binary point */
+
+ if ( e <= DBL_MIN_EXP - DBL_MANT_DIG
+ || f != 1.0 / FLT_RADIX ) {
+
+ /*
+ * Either f isn't the smallest significand or e is
+ * the smallest exponent. mplus and mminus will both be 1.
+ */
+
+ rfac2 += 1;
+ sfac2 = 1 - e * log2FLT_RADIX;
+ mplusfac2 = 0;
+ mminusfac2 = 0;
+
+ } else {
+
+ /*
+ * f is the smallest significand, but e is not the smallest
+ * exponent. We need to scale by FLT_RADIX again to cope
+ * with the fact that v's predecessor has a smaller exponent.
+ */
+
+ rfac2 += 1 + log2FLT_RADIX;
+ sfac2 = 1 + log2FLT_RADIX * ( 1 - e );
+ mplusfac2 = FLT_RADIX;
+ mminusfac2 = 0;
+
+ }
+ }
+
+ /*
+ * Estimate the highest power of ten that will be
+ * needed to hold the result.
+ */
+
+ k = (int) ceil( log( v ) / log( 10. ) );
+ if ( k >= 0 ) {
+ sfac2 += k;
+ sfac5 = k;
+ } else {
+ rfac2 -= k;
+ mplusfac2 -= k;
+ mminusfac2 -= k;
+ rfac5 = -k;
+ }
+
+ /*
+ * Scale r, s, mplus, mminus by the appropriate powers of 2 and 5.
+ */
+
+ mp_init_set( &mplus, 1 );
+ for ( i = 0; i <= 8; ++i ) {
+ if ( rfac5 & ( 1 << i ) ) {
+ mp_mul( &mplus, pow5+i, &mplus );
+ }
+ }
+ mp_mul( &r, &mplus, &r );
+ mp_mul_2d( &r, rfac2, &r );
+ mp_init_copy( &mminus, &mplus );
+ mp_mul_2d( &mplus, mplusfac2, &mplus );
+ mp_mul_2d( &mminus, mminusfac2, &mminus );
+ mp_init_set( &s, 1 );
+ for ( i = 0; i <= 8; ++i ) {
+ if ( sfac5 & ( 1 << i ) ) {
+ mp_mul( &s, pow5+i, &s );
+ }
+ }
+ mp_mul_2d( &s, sfac2, &s );
+
+ /*
+ * It is possible for k to be off by one because we used an
+ * inexact logarithm.
+ */
+
+ mp_init( &temp );
+ mp_add( &r, &mplus, &temp );
+ i = mp_cmp_mag( &temp, &s );
+ if ( i > 0 || ( high_ok && i == 0 ) ) {
+ mp_mul_d( &s, 10, &s );
+ ++k;
+ } else {
+ mp_mul_d( &temp, 10, &temp );
+ i = mp_cmp_mag( &temp, &s );
+ if ( i < 0 || ( high_ok && i == 0 ) ) {
+ mp_mul_d( &r, 10, &r );
+ mp_mul_d( &mplus, 10, &mplus );
+ mp_mul_d( &mminus, 10, &mminus );
+ --k;
+ }
+ }
+
+ /*
+ * At this point, k contains the power of ten by which we're
+ * scaling the result. r/s is at least 1/10 and strictly less
+ * than ten, and v = r/s * 10**k. mplus and mminus give the
+ * rounding limits.
+ */
+
+ for ( ; ; ) {
+ int tc1, tc2;
+ mp_mul_d( &r, 10, &r );
+ mp_div( &r, &s, &temp, &r ); /* temp = 10r / s; r = 10r mod s */
+ i = temp.dp[0];
+ mp_mul_d( &mplus, 10, &mplus );
+ mp_mul_d( &mminus, 10, &mminus );
+ tc1 = mp_cmp_mag( &r, &mminus );
+ if ( low_ok ) {
+ tc1 = ( tc1 <= 0 );
+ } else {
+ tc1 = ( tc1 < 0 );
+ }
+ mp_add( &r, &mplus, &temp );
+ tc2 = mp_cmp_mag( &temp, &s );
+ if ( high_ok ) {
+ tc2 = ( tc2 >= 0 );
+ } else {
+ tc2= ( tc2 > 0 );
+ }
+ if ( ! tc1 ) {
+ if ( !tc2 ) {
+ *strPtr++ = '0' + i;
+ } else {
+ c = (char) (i + '1');
+ break;
+ }
+ } else {
+ if ( !tc2 ) {
+ c = (char) (i + '0');
+ } else {
+ mp_mul_2d( &r, 1, &r );
+ n = mp_cmp_mag( &r, &s );
+ if ( n < 0 ) {
+ c = (char) (i + '0');
+ } else {
+ c = (char) (i + '1');
+ }
+ }
+ break;
+ }
+ };
+ *strPtr++ = c;
+ *strPtr++ = '\0';
+
+ /* Free memory */
+
+ mp_clear_multi( &r, &s, &mplus, &mminus, &temp, NULL );
+ return k;
+
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclInitDoubleConversion --
+ *
+ * Initializes constants that are needed for conversions to and
+ * from 'double'
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * The log base 2 of the floating point radix, the number of
+ * bits in a double mantissa, and a table of the powers of five
+ * and ten are computed and stored.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+TclInitDoubleConversion( void )
+{
+ int i;
+ int x;
+ double d;
+ 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 ) {
+ mmaxpow = x;
+ } else {
+ mmaxpow = MAXPOW;
+ }
+ for ( i = 0; i <= mmaxpow; ++i ) {
+ pow10[i] = d;
+ d *= 10.0;
+ }
+ 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 );
+ }
+ 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;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclFinalizeDoubleConversion --
+ *
+ * Cleans up this file on exit.
+ *
+ * Results:
+ * None
+ *
+ * Side effects:
+ * Memory allocated by TclInitDoubleConversion is freed.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+TclFinalizeDoubleConversion()
+{
+ int i;
+ for ( i = 0; i < 9; ++i ) {
+ mp_clear( pow5 + i );
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclBignumToDouble --
+ *
+ * Convert an arbitrary-precision integer to a native floating
+ * point number.
+ *
+ * Results:
+ * Returns the converted number. Sets errno to ERANGE if the
+ * number is too large to convert.
+ *
+ *----------------------------------------------------------------------
+ */
+
+double
+TclBignumToDouble( mp_int* a )
+ /* Integer to convert */
+{
+ 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 );
+ if ( bits > DBL_MAX_EXP * log2FLT_RADIX ) {
+ errno = ERANGE;
+ return HUGE_VAL;
+ }
+ shift = mantBits + 1 - 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 );
+ }
+ mp_add_d( &b, 1, &b );
+ mp_div_2d( &b, 1, &b, NULL );
+
+ /* 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 );
+
+ /* Scale the result to the correct number of bits. */
+
+ r = ldexp( r, bits - mantBits );
+
+ /* Return the result with the appropriate sign. */
+
+ if ( a->sign == MP_ZPOS ) {
+ return r;
+ } else {
+ return -r;
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * SafeLdExp --
+ *
+ * Do an 'ldexp' operation, but handle denormals gracefully.
+ *
+ * Results:
+ * Returns the appropriately scaled value.
+ *
+ * On some platforms, 'ldexp' fails when presented with a number
+ * too small to represent as a normalized double. This routine
+ * does 'ldexp' in two steps for those numbers, to return correctly
+ * denormalized values.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static double
+SafeLdExp( double fract, int expt )
+{
+ int minexpt = DBL_MIN_EXP * log2FLT_RADIX;
+ volatile double a, b, retval;
+ if ( expt < minexpt ) {
+ a = ldexp( fract, expt - mantBits - minexpt );
+ b = ldexp( 1.0, mantBits + minexpt );
+ retval = a * b;
+ } else {
+ retval = ldexp( fract, expt );
+ }
+ return retval;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclFormatNaN --
+ *
+ * Makes the string representation of a "Not a Number"
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Stores the string representation in the supplied buffer,
+ * which must be at least TCL_DOUBLE_SPACE characters.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+TclFormatNaN( double value, /* The Not-a-Number to format */
+ char* buffer ) /* String representation */
+{
+#ifndef IEEE_FLOATING_POINT
+ strcpy( buffer, "NaN" );
+ return;
+#else
+
+ union {
+ double dv;
+ Tcl_WideUInt iv;
+ } bitwhack;
+
+ bitwhack.dv = value;
+ if ( bitwhack.iv & ((Tcl_WideUInt) 1 << 63 ) ) {
+ bitwhack.iv &= ~ ((Tcl_WideUInt) 1 << 63 );
+ *buffer++ = '-';
+ }
+ *buffer++ = 'N'; *buffer++ = 'a'; *buffer++ = 'N';
+ bitwhack.iv &= (((Tcl_WideUInt) 1) << 51) - 1;
+ if ( bitwhack.iv != 0 ) {
+ sprintf( buffer, "(%" TCL_LL_MODIFIER "x)", bitwhack.iv );
+ } else {
+ *buffer = '\0';
+ }
+
+#endif
+}
diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c
index 9d01456..0e8c1f1 100644
--- a/generic/tclStringObj.c
+++ b/generic/tclStringObj.c
@@ -33,7 +33,7 @@
* 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.36 2005/04/01 15:17:26 msofer Exp $ */
+ * RCS: @(#) $Id: tclStringObj.c,v 1.37 2005/05/10 18:34:49 kennykb Exp $ */
#include "tclInt.h"
diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c
index 020f1ab..8240c9c 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.115 2005/05/05 18:38:04 dgp Exp $
+ * RCS: @(#) $Id: tclStubInit.c,v 1.116 2005/05/10 18:34:49 kennykb Exp $
*/
#include "tclInt.h"
@@ -303,6 +303,11 @@ TclIntStubs tclIntStubs = {
TclStackFree, /* 216 */
TclPushStackFrame, /* 217 */
TclPopStackFrame, /* 218 */
+ TclBN_mp_div_d, /* 219 */
+ TclBN_mp_mul_d, /* 220 */
+ TclBN_mp_clear, /* 221 */
+ TclBN_mp_init, /* 222 */
+ TclBN_mp_read_radix, /* 223 */
};
TclIntPlatStubs tclIntPlatStubs = {
@@ -971,6 +976,10 @@ TclStubs tclStubs = {
Tcl_SetTimeProc, /* 552 */
Tcl_QueryTimeProc, /* 553 */
Tcl_ChannelThreadActionProc, /* 554 */
+ Tcl_NewBignumObj, /* 555 */
+ Tcl_DbNewBignumObj, /* 556 */
+ Tcl_SetBignumObj, /* 557 */
+ Tcl_GetBignumFromObj, /* 558 */
};
/* !END!: Do not edit above this line. */
diff --git a/generic/tclTest.c b/generic/tclTest.c
index cb3a314..68b8963 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.88 2005/01/28 13:38:57 dkf Exp $
+ * RCS: @(#) $Id: tclTest.c,v 1.89 2005/05/10 18:34:50 kennykb Exp $
*/
#define TCL_TEST
diff --git a/generic/tclTestObj.c b/generic/tclTestObj.c
index 5c45d70..9e29ed1 100644
--- a/generic/tclTestObj.c
+++ b/generic/tclTestObj.c
@@ -8,14 +8,16 @@
*
* Copyright (c) 1995-1998 Sun Microsystems, Inc.
* Copyright (c) 1999 by Scriptics Corporation.
+ * 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: tclTestObj.c,v 1.12 2002/12/04 13:09:24 vincentdarley Exp $
+ * RCS: @(#) $Id: tclTestObj.c,v 1.13 2005/05/10 18:34:50 kennykb Exp $
*/
#include "tclInt.h"
+#include "tommath.h"
/*
* An array of Tcl_Obj pointers used in the commands that operate on or get
@@ -37,6 +39,9 @@ static int GetVariableIndex _ANSI_ARGS_((Tcl_Interp *interp,
static void SetVarToObj _ANSI_ARGS_((int varIndex,
Tcl_Obj *objPtr));
int TclObjTest_Init _ANSI_ARGS_((Tcl_Interp *interp));
+static int TestbignumobjCmd _ANSI_ARGS_((ClientData dummy,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *CONST objv[]));
static int TestbooleanobjCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int objc,
Tcl_Obj *CONST objv[]));
@@ -95,6 +100,8 @@ TclObjTest_Init(interp)
varPtr[i] = NULL;
}
+ Tcl_CreateObjCommand( interp, "testbignumobj", TestbignumobjCmd,
+ (ClientData) 0, (Tcl_CmdDeleteProc*) NULL );
Tcl_CreateObjCommand(interp, "testbooleanobj", TestbooleanobjCmd,
(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateObjCommand(interp, "testconvertobj", TestconvertobjCmd,
@@ -115,6 +122,169 @@ TclObjTest_Init(interp)
/*
*----------------------------------------------------------------------
*
+ * TestbignumobjCmd --
+ *
+ * This procedure implmenets the "testbignumobj" command. It is used
+ * to exercise the bignum Tcl object type implementation.
+ *
+ * Results:
+ * Returns a standard Tcl object result.
+ *
+ * Side effects:
+ * Creates and frees bignum objects; converts objects to have bignum
+ * type.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+TestbignumobjCmd( clientData, interp, objc, objv )
+ ClientData clientData; /* unused */
+ Tcl_Interp* interp; /* Tcl interpreter */
+ int objc; /* Argument count */
+ Tcl_Obj* CONST objv[]; /* Argument vector */
+{
+
+ const char * subcmds[] = {
+ "set", "get", "mult10", "div10",
+ NULL
+ };
+ enum options {
+ BIGNUM_SET, BIGNUM_GET, BIGNUM_MULT10, BIGNUM_DIV10
+ };
+
+ int index;
+ int varIndex;
+ char* string;
+ mp_int bignumValue, newValue;
+
+ if ( objc < 3 ) {
+ Tcl_WrongNumArgs( interp, 1, objv, "option ?arg?..." );
+ return TCL_ERROR;
+ }
+ if ( Tcl_GetIndexFromObj( interp, objv[1], subcmds, "option", 0, &index )
+ != TCL_OK ) {
+ return TCL_ERROR;
+ }
+ string = Tcl_GetString( objv[ 2 ] );
+ if ( GetVariableIndex( interp, string, &varIndex ) != TCL_OK ) {
+ return TCL_ERROR;
+ }
+
+ switch ( index )
+ {
+ case BIGNUM_SET:
+ if ( objc != 4 ) {
+ Tcl_WrongNumArgs( interp, 2, objv, "var value" );
+ }
+ string = Tcl_GetString( objv[3] );
+ if ( mp_init( &bignumValue ) != MP_OKAY ) {
+ Tcl_SetObjResult( interp,
+ Tcl_NewStringObj( "error in mp_init", -1 ) );
+ return TCL_ERROR;
+ }
+ if ( mp_read_radix( &bignumValue, string, 10 )
+ != MP_OKAY ) {
+ mp_clear( &bignumValue );
+ Tcl_SetObjResult( interp,
+ Tcl_NewStringObj( "error in mp_read_radix",
+ -1 ) );
+ return TCL_ERROR;
+ }
+
+ /*
+ * If the object currently bound to the variable with index
+ * varIndex has ref count 1 (i.e. the object is unshared) we can
+ * modify that object directly. Otherwise, if RC>1 (i.e. the
+ * object is shared), we must create a new object to modify/set and
+ * decrement the old formerly-shared object's ref count. This is
+ * "copy on write".
+ */
+
+ if ((varPtr[varIndex] != NULL)
+ && !Tcl_IsShared(varPtr[varIndex])) {
+ Tcl_SetBignumObj(varPtr[varIndex], &bignumValue );
+ } else {
+ SetVarToObj(varIndex, Tcl_NewBignumObj(&bignumValue));
+ }
+ break;
+
+ case BIGNUM_GET:
+ if ( objc != 3 ) {
+ Tcl_WrongNumArgs( interp, 2, objv, "varIndex" );
+ return TCL_ERROR;
+ }
+ if ( CheckIfVarUnset( interp, varIndex ) ) {
+ return TCL_ERROR;
+ }
+ break;
+
+ case BIGNUM_MULT10:
+ if ( objc != 3 ) {
+ Tcl_WrongNumArgs( interp, 2, objv, "varIndex" );
+ return TCL_ERROR;
+ }
+ if ( CheckIfVarUnset( interp, varIndex ) ) {
+ return TCL_ERROR;
+ }
+ if ( Tcl_GetBignumFromObj( interp, varPtr[varIndex],
+ &bignumValue ) != TCL_OK ) {
+ return TCL_ERROR;
+ }
+ if ( mp_init( &newValue ) != MP_OKAY
+ || ( mp_mul_d( &bignumValue, 10, &newValue ) != MP_OKAY ) ) {
+ mp_clear( &bignumValue );
+ mp_clear( &newValue );
+ Tcl_SetObjResult( interp,
+ Tcl_NewStringObj( "error in mp_mul_d",
+ -1 ) );
+ return TCL_ERROR;
+ }
+ mp_clear( &bignumValue );
+ if ( !Tcl_IsShared( varPtr[varIndex] ) ) {
+ Tcl_SetBignumObj( varPtr[varIndex], &newValue );
+ } else {
+ SetVarToObj( varIndex, Tcl_NewBignumObj( &newValue ) );
+ }
+ break;
+
+ case BIGNUM_DIV10:
+ if ( objc != 3 ) {
+ Tcl_WrongNumArgs( interp, 2, objv, "varIndex" );
+ return TCL_ERROR;
+ }
+ if ( CheckIfVarUnset( interp, varIndex ) ) {
+ return TCL_ERROR;
+ }
+ if ( Tcl_GetBignumFromObj( interp, varPtr[varIndex],
+ &bignumValue ) != TCL_OK ) {
+ return TCL_ERROR;
+ }
+ if ( mp_init( &newValue ) != MP_OKAY
+ || ( mp_div_d( &bignumValue, 10, &newValue, NULL )
+ != MP_OKAY ) ) {
+ mp_clear( &bignumValue );
+ mp_clear( &newValue );
+ Tcl_SetObjResult( interp,
+ Tcl_NewStringObj( "error in mp_div_d",
+ -1 ) );
+ return TCL_ERROR;
+ }
+ mp_clear( &bignumValue );
+ if ( !Tcl_IsShared( varPtr[varIndex] ) ) {
+ Tcl_SetBignumObj( varPtr[varIndex], &newValue );
+ } else {
+ SetVarToObj( varIndex, Tcl_NewBignumObj( &newValue ) );
+ }
+ }
+
+ Tcl_SetObjResult( interp, varPtr[varIndex] );
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* TestbooleanobjCmd --
*
* This procedure implements the "testbooleanobj" command. It is used
diff --git a/generic/tclThread.c b/generic/tclThread.c
index 6fc558c..2afc284 100644
--- a/generic/tclThread.c
+++ b/generic/tclThread.c
@@ -9,7 +9,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclThread.c,v 1.10 2005/02/03 13:31:10 dkf Exp $
+ * RCS: @(#) $Id: tclThread.c,v 1.11 2005/05/10 18:34:50 kennykb Exp $
*/
#include "tclInt.h"
diff --git a/generic/tclThreadAlloc.c b/generic/tclThreadAlloc.c
index 0e8c087..c03cc9e 100755
--- a/generic/tclThreadAlloc.c
+++ b/generic/tclThreadAlloc.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: tclThreadAlloc.c,v 1.15 2005/04/16 08:00:17 vasiljevic Exp $
+ * RCS: @(#) $Id: tclThreadAlloc.c,v 1.16 2005/05/10 18:34:50 kennykb Exp $
*/
#include "tclInt.h"
diff --git a/generic/tclThreadTest.c b/generic/tclThreadTest.c
index 7b2ac56..299a5aa 100644
--- a/generic/tclThreadTest.c
+++ b/generic/tclThreadTest.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: tclThreadTest.c,v 1.18 2005/03/25 00:35:03 dgp Exp $
+ * RCS: @(#) $Id: tclThreadTest.c,v 1.19 2005/05/10 18:34:50 kennykb Exp $
*/
#include "tclInt.h"
diff --git a/generic/tclTimer.c b/generic/tclTimer.c
index 14cdd27..a8728f4 100644
--- a/generic/tclTimer.c
+++ b/generic/tclTimer.c
@@ -9,7 +9,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclTimer.c,v 1.14 2005/03/23 22:09:28 dgp Exp $
+ * RCS: @(#) $Id: tclTimer.c,v 1.15 2005/05/10 18:34:51 kennykb Exp $
*/
#include "tclInt.h"
diff --git a/generic/tclTomMath.h b/generic/tclTomMath.h
new file mode 100644
index 0000000..4ffbea2
--- /dev/null
+++ b/generic/tclTomMath.h
@@ -0,0 +1,109 @@
+/*
+ * tclTomMath.h --
+ *
+ * Interface information that comes in at the head of
+ * <tommath.h> to adapt the API to Tcl's linkage conventions.
+ *
+ * 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: tclTomMath.h,v 1.2 2005/05/10 18:34:51 kennykb Exp $
+ */
+
+#ifndef TCLTOMMATH_H
+#define TCLTOMMATH_H 1
+
+#include <tcl.h>
+#include <stdlib.h>
+
+
+/* Define TOMMATH_DLLIMPORT and TOMMATH_DLLEXPORT to suit the compiler */
+
+#ifdef STATIC_BUILD
+# define TOMMATH_DLLIMPORT
+# define TOMMATH_DLLEXPORT
+#else
+# if (defined(__WIN32__) && (defined(_MSC_VER) || (__BORLANDC__ >= 0x0550) || defined(__LCC__) || defined(__WATCOMC__) || (defined(__GNUC__) && defined(__declspec))))
+# define TOMMATH_DLLIMPORT __declspec(dllimport)
+# define TOMMATH_DLLEXPORT __declspec(dllexport)
+# else
+# define TOMMATH_DLLIMPORT
+# define TOMMATH_DLLEXPORT
+# endif
+#endif
+
+/* Define TOMMATH_STORAGE_CLASS according to the build options. */
+
+#undef TOMMATH_STORAGE_CLASS
+#ifdef BUILD_tcl
+# define TOMMATH_STORAGE_CLASS TOMMATH_DLLEXPORT
+#else
+# ifdef USE_TCL_STUBS
+# define TOMMATH_STORAGE_CLASS
+# else
+# define TOMMATH_STORAGE_CLASS TOMMATH_DLLIMPORT
+# endif
+#endif
+
+/* Define custom memory allocation for libtommath */
+
+#define XMALLOC(x) TclBNAlloc(x)
+#define XFREE(x) TclBNFree(x)
+#define XREALLOC(x,n) TclBNRealloc(x,n)
+#define XCALLOC(n,x) TclBNCalloc(n,x)
+void* TclBNAlloc( size_t );
+void* TclBNRealloc( void*, size_t );
+void TclBNFree( void* );
+void* TclBNCalloc( size_t, size_t );
+
+/* Rename all global symboles in libtommath to avoid linkage conflicts */
+
+#define KARATSUBA_MUL_CUTOFF TclBNKaratsubaMulCutoff
+#define KARATSUBA_SQR_CUTOFF TclBNKaratsubaSqrCutoff
+#define TOOM_MUL_CUTOFF TclBNToomMulCutoff
+#define TOOM_SQR_CUTOFF TclBNToomSqrCutoff
+
+#define mp_s_rmap TclBNMpSRmap
+
+#define bn_reverse TclBN_reverse
+#define fast_s_mp_mul_digs TclBN_fast_s_mp_mul_digs
+#define mp_add TclBN_mp_add
+#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_mag TclBN_mp_cmp_mag
+#define mp_copy TclBN_mp_copy
+#define mp_count_bits TclBN_mp_count_bits
+#define mp_div TclBN_mp_div
+#define mp_div_d TclBN_mp_div_d
+#define mp_div_2 TclBN_mp_div_2
+#define mp_div_2d TclBN_mp_div_2d
+#define mp_div_3 TclBN_mp_div_3
+#define mp_exch TclBN_mp_exch
+#define mp_grow TclBN_mp_grow
+#define mp_init TclBN_mp_init
+#define mp_init_copy TclBN_mp_init_copy
+#define mp_init_multi TclBN_mp_init_multi
+#define mp_init_size TclBN_mp_init_size
+#define mp_karatsuba_mul TclBN_mp_karatsuba_mul
+#define mp_lshd TclBN_mp_lshd
+#define mp_mod_2d TclBN_mp_mod_2d
+#define mp_mul TclBN_mp_mul
+#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_radix_size TclBN_mp_radix_size
+#define mp_read_radix TclBN_mp_read_radix
+#define mp_rshd TclBN_mp_rshd
+#define mp_sub TclBN_mp_sub
+#define mp_toom_mul TclBN_mp_toom_mul
+#define mp_toradix_n TclBN_mp_toradix_n
+#define mp_zero TclBN_mp_zero
+#define s_mp_add TclBN_s_mp_add
+#define s_mp_mul_digs TclBN_s_mp_mul_digs
+#define s_mp_sub TclBN_s_mp_sub
+
+#endif
diff --git a/generic/tclTomMathInterface.c b/generic/tclTomMathInterface.c
new file mode 100644
index 0000000..89537b9
--- /dev/null
+++ b/generic/tclTomMathInterface.c
@@ -0,0 +1,143 @@
+/*
+ *----------------------------------------------------------------------
+ *
+ * tclTomMathInterface.c --
+ *
+ * This file contains procedures that are used as a 'glue'
+ * layer between Tcl and libtommath.
+ *
+ * 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: tclTomMathInterface.c,v 1.2 2005/05/10 18:34:51 kennykb Exp $
+ */
+
+#include "tclInt.h"
+#include "tommath.h"
+#include <limits.h>
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclBNAlloc --
+ *
+ * Allocate memory for libtommath.
+ *
+ * Results:
+ * Returns a pointer to the allocated block.
+ *
+ * This procedure is a wrapper around Tcl_Alloc, needed because of
+ * a mismatched type signature between Tcl_Alloc and malloc.
+ *
+ *----------------------------------------------------------------------
+ */
+
+extern void *
+TclBNAlloc( size_t x )
+{
+ return (void*) Tcl_Alloc( (unsigned int) x );
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclBNAlloc --
+ *
+ * Change the size of an allocated block of memory in libtommath
+ *
+ * Results:
+ * Returns a pointer to the allocated block.
+ *
+ * This procedure is a wrapper around Tcl_Realloc, needed because of
+ * a mismatched type signature between Tcl_Realloc and realloc.
+ *
+ *----------------------------------------------------------------------
+ */
+
+extern void *
+TclBNRealloc( void* p, size_t s )
+{
+ return (void*) Tcl_Realloc( (char*) p, (unsigned int) s );
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclBNFree --
+ *
+ * Free allocated memory in libtommath.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Memory is freed.
+ *
+ * This function is simply a wrapper around Tcl_Free, needed in
+ * libtommath because of a type mismatch between free and Tcl_Free.
+ *
+ *----------------------------------------------------------------------
+ */
+
+extern void
+TclBNFree( void* p )
+{
+ Tcl_Free( (char*) p);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclBNInitBignumFromLong --
+ *
+ * Allocate and initialize a 'bignum' from a native 'long'.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * The 'bignum' is constructed.
+ *
+ *----------------------------------------------------------------------
+ */
+
+extern void
+TclBNInitBignumFromLong( mp_int* a, long initVal )
+{
+
+ int status;
+ unsigned long v;
+ mp_digit* p;
+
+ /*
+ * Allocate enough memory to hold the largest possible long
+ */
+
+ status = mp_init_size( a, ( ( CHAR_BIT * sizeof( long ) + DIGIT_BIT - 1 )
+ / DIGIT_BIT ) );
+ if ( status != MP_OKAY ) {
+ Tcl_Panic( "initialization failure in TclBNInitBignumFromLong" );
+ }
+
+ /* Convert arg to sign and magnitude */
+
+ if ( initVal < 0 ) {
+ a->sign = MP_NEG;
+ v = -initVal;
+ } else {
+ a->sign = MP_ZPOS;
+ v = initVal;
+ }
+
+ /* 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/tclTrace.c b/generic/tclTrace.c
index f717c8d..3a15ac8 100644
--- a/generic/tclTrace.c
+++ b/generic/tclTrace.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: tclTrace.c,v 1.22 2005/03/10 22:10:38 dgp Exp $
+ * RCS: @(#) $Id: tclTrace.c,v 1.23 2005/05/10 18:34:51 kennykb Exp $
*/
#include "tclInt.h"
diff --git a/generic/tclUtf.c b/generic/tclUtf.c
index d3ac7e1..7a5494a 100644
--- a/generic/tclUtf.c
+++ b/generic/tclUtf.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: tclUtf.c,v 1.33 2005/05/03 18:08:20 dgp Exp $
+ * RCS: @(#) $Id: tclUtf.c,v 1.34 2005/05/10 18:34:51 kennykb Exp $
*/
#include "tclInt.h"
diff --git a/generic/tclUtil.c b/generic/tclUtil.c
index 869169a..278380d 100644
--- a/generic/tclUtil.c
+++ b/generic/tclUtil.c
@@ -11,10 +11,32 @@
* 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.58 2005/05/05 18:38:06 dgp Exp $
+ * RCS: @(#) $Id: tclUtil.c,v 1.59 2005/05/10 18:34:52 kennykb Exp $
*/
#include "tclInt.h"
+#include <float.h>
+#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
@@ -56,12 +78,9 @@ static ProcessGlobalValue executableName = {0, 0, NULL, NULL, NULL, NULL, NULL};
* TclPrecTraceProc.
*/
-static char precisionString[10] = "12";
- /* The string value of all the tcl_precision
- * variables. */
-static char precisionFormat[10] = "%.12g";
- /* The format string actually used in calls
- * to sprintf. */
+static int precision = 0; /* Precision of floating point conversions,
+ * in the range 0-17 inclusive. */
+
TCL_DECLARE_MUTEX(precisionMutex)
/*
@@ -1879,33 +1898,125 @@ Tcl_PrintDouble(interp, value, dst)
* characters. */
{
char *p, c;
+ int prec;
+ int exp;
+ int signum;
+ char buffer[TCL_DOUBLE_SPACE];
Tcl_UniChar ch;
Tcl_MutexLock(&precisionMutex);
- sprintf(dst, precisionFormat, value);
+ prec = precision;
Tcl_MutexUnlock(&precisionMutex);
/*
- * If the ASCII result looks like an integer, add ".0" so that it
- * doesn't look like an integer anymore. This prevents floating-point
- * values from being converted to integers unintentionally.
- * Check for ASCII specifically to speed up the function.
+ * If prec == 0, then use TclDoubleDigits to develop a decimal
+ * significand and exponent, then format it in E or F format as
+ * appropriate. If prec != 0, use the native sprintf and then
+ * add a trailing ".0" if there is no decimal point in the rep.
*/
- for (p = dst; *p != 0; ) {
- if (UCHAR(*p) < 0x80) {
- c = *p++;
- } else {
- p += Tcl_UtfToUniChar(p, &ch);
- c = UCHAR(ch);
+ if ( prec == 0 ) {
+
+ /* Handle NaN */
+
+ if ( IS_NAN( value ) ) {
+ TclFormatNaN( value, dst );
+ return;
}
- if ((c == '.') || isalpha(UCHAR(c))) { /* INTL: ISO only. */
+
+ /* Handle infinities */
+
+ if ( IS_INF( value ) ) {
+ if ( value < 0 ) {
+ strcpy( dst, "-Inf" );
+ } else {
+ strcpy( dst, "Inf" );
+ }
return;
}
+
+ /* Ordinary (normal and denormal) values */
+
+ exp = TclDoubleDigits( buffer, value, &signum );
+ if ( signum ) {
+ *dst++ = '-';
+ }
+ prec = strlen( buffer );
+ p = buffer;
+ if ( exp < -3 || exp > 17 ) {
+
+ /* E format for numbers < 1e-3 or >= 1e17 */
+
+ *dst++ = *p++;
+ c = *p;
+ if ( c != '\0' ) {
+ *dst++ = '.';
+ while ( c != '\0' ) {
+ *dst++ = c;
+ c = *++p;
+ }
+ }
+ sprintf( dst, "e%+d", exp-1 );
+ } else {
+
+ /* F format for others */
+
+ if ( exp <= 0 ) {
+ *dst++ = '0';
+ }
+ c = *p;
+ while ( exp-- > 0 ) {
+ if ( c != '\0' ) {
+ *dst++ = c;
+ c = *++p;
+ } else {
+ *dst++ = '0';
+ }
+ }
+ *dst++ = '.';
+ if ( c == '\0' ) {
+ *dst++ = '0';
+ } else {
+ while ( ++exp < 0 ) {
+ *dst++ = '0';
+ }
+ while ( c != '\0' ) {
+ *dst++ = c;
+ c = *++p;
+ }
+ }
+ *dst++ = '\0';
+ }
+
+ } else {
+
+ /* tcl_precision is supplied, pass it to the native sprintf */
+
+ sprintf( dst, "%.*g", prec, value );
+
+ /*
+ * If the ASCII result looks like an integer, add ".0" so that it
+ * doesn't look like an integer anymore. This prevents floating-point
+ * values from being converted to integers unintentionally.
+ * Check for ASCII specifically to speed up the function.
+ */
+
+ for (p = dst; *p != 0; ) {
+ if (UCHAR(*p) < 0x80) {
+ c = *p++;
+ } else {
+ p += Tcl_UtfToUniChar(p, &ch);
+ c = UCHAR(ch);
+ }
+ if ((c == '.') || isalpha(UCHAR(c))) { /* INTL: ISO only. */
+ return;
+ }
+ }
+ p[0] = '.';
+ p[1] = '0';
+ p[2] = 0;
+
}
- p[0] = '.';
- p[1] = '0';
- p[2] = 0;
}
/*
@@ -1937,8 +2048,7 @@ TclPrecTraceProc(clientData, interp, name1, name2, flags)
CONST char *name2; /* Second part of variable name. */
int flags; /* Information about what happened. */
{
- CONST char *value;
- char *end;
+ Tcl_Obj* value;
int prec;
/*
@@ -1961,11 +2071,11 @@ TclPrecTraceProc(clientData, interp, name1, name2, flags)
* out of date.
*/
- Tcl_MutexLock(&precisionMutex);
if (flags & TCL_TRACE_READS) {
- Tcl_SetVar2(interp, name1, name2, precisionString,
- flags & TCL_GLOBAL_ONLY);
+ Tcl_MutexLock(&precisionMutex);
+ Tcl_SetVar2Ex( interp, name1, name2, Tcl_NewIntObj( precision ),
+ flags & TCL_GLOBAL_ONLY );
Tcl_MutexUnlock(&precisionMutex);
return (char *) NULL;
}
@@ -1978,25 +2088,21 @@ TclPrecTraceProc(clientData, interp, name1, name2, flags)
*/
if (Tcl_IsSafe(interp)) {
- Tcl_SetVar2(interp, name1, name2, precisionString,
- flags & TCL_GLOBAL_ONLY);
+ Tcl_MutexLock(&precisionMutex);
+ Tcl_SetVar2Ex( interp, name1, name2, Tcl_NewIntObj( precision ),
+ flags & TCL_GLOBAL_ONLY );
Tcl_MutexUnlock(&precisionMutex);
return "can't modify precision from a safe interpreter";
}
- value = Tcl_GetVar2(interp, name1, name2, flags & TCL_GLOBAL_ONLY);
- if (value == NULL) {
- value = "";
- }
- prec = strtoul(value, &end, 10);
- if ((prec <= 0) || (prec > TCL_MAX_PREC) || (prec > 100) ||
- (end == value) || (*end != 0)) {
- Tcl_SetVar2(interp, name1, name2, precisionString,
- flags & TCL_GLOBAL_ONLY);
- Tcl_MutexUnlock(&precisionMutex);
+ value = Tcl_GetVar2Ex(interp, name1, name2, flags & TCL_GLOBAL_ONLY);
+ if ( value == NULL
+ || Tcl_GetIntFromObj( (Tcl_Interp*) NULL, value, &prec ) != TCL_OK
+ || prec < 0
+ || prec > TCL_MAX_PREC ) {
return "improper value for precision";
}
- TclFormatInt(precisionString, prec);
- sprintf(precisionFormat, "%%.%dg", prec);
+ Tcl_MutexLock( &precisionMutex );
+ precision = prec;
Tcl_MutexUnlock(&precisionMutex);
return (char *) NULL;
}
diff --git a/generic/tclVar.c b/generic/tclVar.c
index 314f958..6cdedc9 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.105 2005/05/05 18:38:06 dgp Exp $
+ * RCS: @(#) $Id: tclVar.c,v 1.106 2005/05/10 18:34:52 kennykb Exp $
*/
#include "tclInt.h"
diff --git a/generic/tommath.h b/generic/tommath.h
new file mode 100644
index 0000000..a9983a4
--- /dev/null
+++ b/generic/tommath.h
@@ -0,0 +1,591 @@
+/* LibTomMath, multiple-precision integer library -- Tom St Denis
+ *
+ * LibTomMath is a library that provides multiple-precision
+ * integer arithmetic as well as number theoretic functionality.
+ *
+ * The library was designed directly after the MPI library by
+ * Michael Fromberger but has been written from scratch with
+ * additional optimizations in place.
+ *
+ * The library is free for all purposes without any express
+ * guarantee it works.
+ *
+ * Tom St Denis, tomstdenis@iahu.ca, http://math.libtomcrypt.org
+ */
+#ifndef BN_H_
+#define BN_H_
+
+#ifdef TCL_TOMMATH
+#include <tclTomMath.h>
+#endif
+#ifndef TOMMATH_STORAGE_CLASS
+#define TOMMATH_STORAGE_CLASS extern
+#endif
+
+#include <stdio.h>
+#include <string.h>
+#include <stdlib.h>
+#include <ctype.h>
+#include <limits.h>
+
+#include <tommath_class.h>
+
+#undef MIN
+#define MIN(x,y) ((x)<(y)?(x):(y))
+#undef MAX
+#define MAX(x,y) ((x)>(y)?(x):(y))
+
+#ifdef __cplusplus
+extern "C" {
+
+/* C++ compilers don't like assigning void * to mp_digit * */
+#define OPT_CAST(x) (x *)
+
+#else
+
+/* C on the other hand doesn't care */
+#define OPT_CAST(x)
+
+#endif
+
+
+/* detect 64-bit mode if possible */
+#if defined(__x86_64__)
+ #if !(defined(MP_64BIT) && defined(MP_16BIT) && defined(MP_8BIT))
+ #define MP_64BIT
+ #endif
+#endif
+
+/* some default configurations.
+ *
+ * A "mp_digit" must be able to hold DIGIT_BIT + 1 bits
+ * A "mp_word" must be able to hold 2*DIGIT_BIT + 1 bits
+ *
+ * At the very least a mp_digit must be able to hold 7 bits
+ * [any size beyond that is ok provided it doesn't overflow the data type]
+ */
+#ifdef MP_8BIT
+#ifndef MP_DIGIT_DECLARED
+ typedef unsigned char mp_digit;
+#define MP_DIGIT_DECLARED
+#endif
+ typedef unsigned short mp_word;
+#elif defined(MP_16BIT)
+#ifndef MP_DIGIT_DECLARED
+ typedef unsigned short mp_digit;
+#define MP_DIGIT_DECLARED
+#endif
+ typedef unsigned long mp_word;
+#elif defined(MP_64BIT)
+ /* for GCC only on supported platforms */
+#ifndef CRYPT
+ typedef unsigned long long ulong64;
+ typedef signed long long long64;
+#endif
+
+#ifndef MP_DIGIT_DECLARED
+ typedef unsigned long mp_digit;
+#define MP_DIGIT_DECLARED
+#endif
+ typedef unsigned long mp_word __attribute__ ((mode(TI)));
+
+ #define DIGIT_BIT 60
+#else
+ /* this is the default case, 28-bit digits */
+
+ /* this is to make porting into LibTomCrypt easier :-) */
+#ifndef CRYPT
+ #if defined(_MSC_VER) || defined(__BORLANDC__)
+ typedef unsigned __int64 ulong64;
+ typedef signed __int64 long64;
+ #else
+ typedef unsigned long long ulong64;
+ typedef signed long long long64;
+ #endif
+#endif
+
+#ifndef MP_DIGIT_DECLARED
+ typedef unsigned long mp_digit;
+#define MP_DIGIT_DECLARED
+#endif
+ typedef ulong64 mp_word;
+
+#ifdef MP_31BIT
+ /* this is an extension that uses 31-bit digits */
+ #define DIGIT_BIT 31
+#else
+ /* default case is 28-bit digits, defines MP_28BIT as a handy macro to test */
+ #define DIGIT_BIT 28
+ #define MP_28BIT
+#endif
+#endif
+
+/* define heap macros */
+#ifndef CRYPT
+ /* default to libc stuff */
+ #ifndef XMALLOC
+ #define XMALLOC malloc
+ #define XFREE free
+ #define XREALLOC realloc
+ #define XCALLOC calloc
+ #else
+ /* prototypes for our heap functions */
+ extern void *XMALLOC(size_t n);
+ extern void *REALLOC(void *p, size_t n);
+ extern void *XCALLOC(size_t n, size_t s);
+ extern void XFREE(void *p);
+ #endif
+#endif
+
+
+/* otherwise the bits per digit is calculated automatically from the size of a mp_digit */
+#ifndef DIGIT_BIT
+ #define DIGIT_BIT ((int)((CHAR_BIT * sizeof(mp_digit) - 1))) /* bits per digit */
+#endif
+
+#define MP_DIGIT_BIT DIGIT_BIT
+#define MP_MASK ((((mp_digit)1)<<((mp_digit)DIGIT_BIT))-((mp_digit)1))
+#define MP_DIGIT_MAX MP_MASK
+
+/* equalities */
+#define MP_LT -1 /* less than */
+#define MP_EQ 0 /* equal to */
+#define MP_GT 1 /* greater than */
+
+#define MP_ZPOS 0 /* positive integer */
+#define MP_NEG 1 /* negative */
+
+#define MP_OKAY 0 /* ok result */
+#define MP_MEM -2 /* out of mem */
+#define MP_VAL -3 /* invalid input */
+#define MP_RANGE MP_VAL
+
+#define MP_YES 1 /* yes response */
+#define MP_NO 0 /* no response */
+
+/* Primality generation flags */
+#define LTM_PRIME_BBS 0x0001 /* BBS style prime */
+#define LTM_PRIME_SAFE 0x0002 /* Safe prime (p-1)/2 == prime */
+#define LTM_PRIME_2MSB_OFF 0x0004 /* force 2nd MSB to 0 */
+#define LTM_PRIME_2MSB_ON 0x0008 /* force 2nd MSB to 1 */
+
+typedef int mp_err;
+
+/* you'll have to tune these... */
+extern int KARATSUBA_MUL_CUTOFF,
+ KARATSUBA_SQR_CUTOFF,
+ TOOM_MUL_CUTOFF,
+ TOOM_SQR_CUTOFF;
+
+/* define this to use lower memory usage routines (exptmods mostly) */
+/* #define MP_LOW_MEM */
+
+/* default precision */
+#ifndef MP_PREC
+ #ifndef MP_LOW_MEM
+ #define MP_PREC 64 /* default digits of precision */
+ #else
+ #define MP_PREC 8 /* default digits of precision */
+ #endif
+#endif
+
+/* size of comba arrays, should be at least 2 * 2**(BITS_PER_WORD - BITS_PER_DIGIT*2) */
+#define MP_WARRAY (1 << (sizeof(mp_word) * CHAR_BIT - 2 * DIGIT_BIT + 1))
+
+/* the infamous mp_int structure */
+#ifndef MP_INT_DECLARED
+#define MP_INT_DECLARED
+typedef struct mp_int mp_int;
+#endif
+struct mp_int {
+ int used, alloc, sign;
+ mp_digit *dp;
+};
+
+/* callback for mp_prime_random, should fill dst with random bytes and return how many read [upto len] */
+typedef int ltm_prime_callback(unsigned char *dst, int len, void *dat);
+
+
+#define USED(m) ((m)->used)
+#define DIGIT(m,k) ((m)->dp[(k)])
+#define SIGN(m) ((m)->sign)
+
+/* error code to char* string */
+TOMMATH_STORAGE_CLASS char *mp_error_to_string(int code);
+
+/* ---> init and deinit bignum functions <--- */
+/* init a bignum */
+TOMMATH_STORAGE_CLASS int mp_init(mp_int *a);
+
+/* free a bignum */
+TOMMATH_STORAGE_CLASS void mp_clear(mp_int *a);
+
+/* init a null terminated series of arguments */
+TOMMATH_STORAGE_CLASS int mp_init_multi(mp_int *mp, ...);
+
+/* clear a null terminated series of arguments */
+TOMMATH_STORAGE_CLASS void mp_clear_multi(mp_int *mp, ...);
+
+/* exchange two ints */
+TOMMATH_STORAGE_CLASS void mp_exch(mp_int *a, mp_int *b);
+
+/* shrink ram required for a bignum */
+TOMMATH_STORAGE_CLASS int mp_shrink(mp_int *a);
+
+/* grow an int to a given size */
+TOMMATH_STORAGE_CLASS int mp_grow(mp_int *a, int size);
+
+/* init to a given number of digits */
+TOMMATH_STORAGE_CLASS int mp_init_size(mp_int *a, int size);
+
+/* ---> Basic Manipulations <--- */
+#define mp_iszero(a) (((a)->used == 0) ? MP_YES : MP_NO)
+#define mp_iseven(a) (((a)->used == 0 || (((a)->dp[0] & 1) == 0)) ? MP_YES : MP_NO)
+#define mp_isodd(a) (((a)->used > 0 && (((a)->dp[0] & 1) == 1)) ? MP_YES : MP_NO)
+
+/* set to zero */
+TOMMATH_STORAGE_CLASS void mp_zero(mp_int *a);
+
+/* set to a digit */
+TOMMATH_STORAGE_CLASS void mp_set(mp_int *a, mp_digit b);
+
+/* set a 32-bit const */
+TOMMATH_STORAGE_CLASS int mp_set_int(mp_int *a, unsigned long b);
+
+/* get a 32-bit value */
+unsigned long mp_get_int(mp_int * a);
+
+/* initialize and set a digit */
+TOMMATH_STORAGE_CLASS int mp_init_set (mp_int * a, mp_digit b);
+
+/* initialize and set 32-bit value */
+TOMMATH_STORAGE_CLASS int mp_init_set_int (mp_int * a, unsigned long b);
+
+/* copy, b = a */
+TOMMATH_STORAGE_CLASS int mp_copy(mp_int *a, mp_int *b);
+
+/* inits and copies, a = b */
+TOMMATH_STORAGE_CLASS int mp_init_copy(mp_int *a, mp_int *b);
+
+/* trim unused digits */
+TOMMATH_STORAGE_CLASS void mp_clamp(mp_int *a);
+
+/* ---> digit manipulation <--- */
+
+/* right shift by "b" digits */
+TOMMATH_STORAGE_CLASS void mp_rshd(mp_int *a, int b);
+
+/* left shift by "b" digits */
+TOMMATH_STORAGE_CLASS int mp_lshd(mp_int *a, int b);
+
+/* c = a / 2**b */
+TOMMATH_STORAGE_CLASS int mp_div_2d(mp_int *a, int b, mp_int *c, mp_int *d);
+
+/* b = a/2 */
+TOMMATH_STORAGE_CLASS int mp_div_2(mp_int *a, mp_int *b);
+
+/* c = a * 2**b */
+TOMMATH_STORAGE_CLASS int mp_mul_2d(mp_int *a, int b, mp_int *c);
+
+/* b = a*2 */
+TOMMATH_STORAGE_CLASS int mp_mul_2(mp_int *a, mp_int *b);
+
+/* c = a mod 2**d */
+TOMMATH_STORAGE_CLASS int mp_mod_2d(mp_int *a, int b, mp_int *c);
+
+/* computes a = 2**b */
+TOMMATH_STORAGE_CLASS int mp_2expt(mp_int *a, int b);
+
+/* Counts the number of lsbs which are zero before the first zero bit */
+TOMMATH_STORAGE_CLASS int mp_cnt_lsb(mp_int *a);
+
+/* I Love Earth! */
+
+/* makes a pseudo-random int of a given size */
+TOMMATH_STORAGE_CLASS int mp_rand(mp_int *a, int digits);
+
+/* ---> binary operations <--- */
+/* c = a XOR b */
+TOMMATH_STORAGE_CLASS int mp_xor(mp_int *a, mp_int *b, mp_int *c);
+
+/* c = a OR b */
+TOMMATH_STORAGE_CLASS int mp_or(mp_int *a, mp_int *b, mp_int *c);
+
+/* c = a AND b */
+TOMMATH_STORAGE_CLASS int mp_and(mp_int *a, mp_int *b, mp_int *c);
+
+/* ---> Basic arithmetic <--- */
+
+/* b = -a */
+TOMMATH_STORAGE_CLASS int mp_neg(mp_int *a, mp_int *b);
+
+/* b = |a| */
+TOMMATH_STORAGE_CLASS int mp_abs(mp_int *a, mp_int *b);
+
+/* compare a to b */
+TOMMATH_STORAGE_CLASS int mp_cmp(mp_int *a, mp_int *b);
+
+/* compare |a| to |b| */
+TOMMATH_STORAGE_CLASS int mp_cmp_mag(mp_int *a, mp_int *b);
+
+/* c = a + b */
+TOMMATH_STORAGE_CLASS int mp_add(mp_int *a, mp_int *b, mp_int *c);
+
+/* c = a - b */
+TOMMATH_STORAGE_CLASS int mp_sub(mp_int *a, mp_int *b, mp_int *c);
+
+/* c = a * b */
+TOMMATH_STORAGE_CLASS int mp_mul(mp_int *a, mp_int *b, mp_int *c);
+
+/* b = a*a */
+TOMMATH_STORAGE_CLASS int mp_sqr(mp_int *a, mp_int *b);
+
+/* a/b => cb + d == a */
+TOMMATH_STORAGE_CLASS int mp_div(mp_int *a, mp_int *b, mp_int *c, mp_int *d);
+
+/* c = a mod b, 0 <= c < b */
+TOMMATH_STORAGE_CLASS int mp_mod(mp_int *a, mp_int *b, mp_int *c);
+
+/* ---> single digit functions <--- */
+
+/* compare against a single digit */
+TOMMATH_STORAGE_CLASS int mp_cmp_d(mp_int *a, mp_digit b);
+
+/* c = a + b */
+TOMMATH_STORAGE_CLASS int mp_add_d(mp_int *a, mp_digit b, mp_int *c);
+
+/* c = a - b */
+TOMMATH_STORAGE_CLASS int mp_sub_d(mp_int *a, mp_digit b, mp_int *c);
+
+/* c = a * b */
+TOMMATH_STORAGE_CLASS int mp_mul_d(mp_int *a, mp_digit b, mp_int *c);
+
+/* a/b => cb + d == a */
+TOMMATH_STORAGE_CLASS int mp_div_d(mp_int *a, mp_digit b, mp_int *c, mp_digit *d);
+
+/* a/3 => 3c + d == a */
+TOMMATH_STORAGE_CLASS int mp_div_3(mp_int *a, mp_int *c, mp_digit *d);
+
+/* c = a**b */
+TOMMATH_STORAGE_CLASS int mp_expt_d(mp_int *a, mp_digit b, mp_int *c);
+
+/* c = a mod b, 0 <= c < b */
+TOMMATH_STORAGE_CLASS int mp_mod_d(mp_int *a, mp_digit b, mp_digit *c);
+
+/* ---> number theory <--- */
+
+/* d = a + b (mod c) */
+TOMMATH_STORAGE_CLASS int mp_addmod(mp_int *a, mp_int *b, mp_int *c, mp_int *d);
+
+/* d = a - b (mod c) */
+TOMMATH_STORAGE_CLASS int mp_submod(mp_int *a, mp_int *b, mp_int *c, mp_int *d);
+
+/* d = a * b (mod c) */
+TOMMATH_STORAGE_CLASS int mp_mulmod(mp_int *a, mp_int *b, mp_int *c, mp_int *d);
+
+/* c = a * a (mod b) */
+TOMMATH_STORAGE_CLASS int mp_sqrmod(mp_int *a, mp_int *b, mp_int *c);
+
+/* c = 1/a (mod b) */
+TOMMATH_STORAGE_CLASS int mp_invmod(mp_int *a, mp_int *b, mp_int *c);
+
+/* c = (a, b) */
+TOMMATH_STORAGE_CLASS int mp_gcd(mp_int *a, mp_int *b, mp_int *c);
+
+/* produces value such that U1*a + U2*b = U3 */
+TOMMATH_STORAGE_CLASS int mp_exteuclid(mp_int *a, mp_int *b, mp_int *U1, mp_int *U2, mp_int *U3);
+
+/* c = [a, b] or (a*b)/(a, b) */
+TOMMATH_STORAGE_CLASS int mp_lcm(mp_int *a, mp_int *b, mp_int *c);
+
+/* finds one of the b'th root of a, such that |c|**b <= |a|
+ *
+ * returns error if a < 0 and b is even
+ */
+TOMMATH_STORAGE_CLASS int mp_n_root(mp_int *a, mp_digit b, mp_int *c);
+
+/* special sqrt algo */
+TOMMATH_STORAGE_CLASS int mp_sqrt(mp_int *arg, mp_int *ret);
+
+/* is number a square? */
+TOMMATH_STORAGE_CLASS int mp_is_square(mp_int *arg, int *ret);
+
+/* computes the jacobi c = (a | n) (or Legendre if b is prime) */
+TOMMATH_STORAGE_CLASS int mp_jacobi(mp_int *a, mp_int *n, int *c);
+
+/* used to setup the Barrett reduction for a given modulus b */
+TOMMATH_STORAGE_CLASS int mp_reduce_setup(mp_int *a, mp_int *b);
+
+/* Barrett Reduction, computes a (mod b) with a precomputed value c
+ *
+ * Assumes that 0 < a <= b*b, note if 0 > a > -(b*b) then you can merely
+ * compute the reduction as -1 * mp_reduce(mp_abs(a)) [pseudo code].
+ */
+TOMMATH_STORAGE_CLASS int mp_reduce(mp_int *a, mp_int *b, mp_int *c);
+
+/* setups the montgomery reduction */
+TOMMATH_STORAGE_CLASS int mp_montgomery_setup(mp_int *a, mp_digit *mp);
+
+/* computes a = B**n mod b without division or multiplication useful for
+ * normalizing numbers in a Montgomery system.
+ */
+TOMMATH_STORAGE_CLASS int mp_montgomery_calc_normalization(mp_int *a, mp_int *b);
+
+/* computes x/R == x (mod N) via Montgomery Reduction */
+TOMMATH_STORAGE_CLASS int mp_montgomery_reduce(mp_int *a, mp_int *m, mp_digit mp);
+
+/* returns 1 if a is a valid DR modulus */
+TOMMATH_STORAGE_CLASS int mp_dr_is_modulus(mp_int *a);
+
+/* sets the value of "d" required for mp_dr_reduce */
+TOMMATH_STORAGE_CLASS void mp_dr_setup(mp_int *a, mp_digit *d);
+
+/* reduces a modulo b using the Diminished Radix method */
+TOMMATH_STORAGE_CLASS int mp_dr_reduce(mp_int *a, mp_int *b, mp_digit mp);
+
+/* returns true if a can be reduced with mp_reduce_2k */
+TOMMATH_STORAGE_CLASS int mp_reduce_is_2k(mp_int *a);
+
+/* determines k value for 2k reduction */
+TOMMATH_STORAGE_CLASS int mp_reduce_2k_setup(mp_int *a, mp_digit *d);
+
+/* reduces a modulo b where b is of the form 2**p - k [0 <= a] */
+TOMMATH_STORAGE_CLASS int mp_reduce_2k(mp_int *a, mp_int *n, mp_digit d);
+
+/* d = a**b (mod c) */
+TOMMATH_STORAGE_CLASS int mp_exptmod(mp_int *a, mp_int *b, mp_int *c, mp_int *d);
+
+/* ---> Primes <--- */
+
+/* number of primes */
+#ifdef MP_8BIT
+ #define PRIME_SIZE 31
+#else
+ #define PRIME_SIZE 256
+#endif
+
+/* table of first PRIME_SIZE primes */
+extern const mp_digit ltm_prime_tab[];
+
+/* result=1 if a is divisible by one of the first PRIME_SIZE primes */
+TOMMATH_STORAGE_CLASS int mp_prime_is_divisible(mp_int *a, int *result);
+
+/* performs one Fermat test of "a" using base "b".
+ * Sets result to 0 if composite or 1 if probable prime
+ */
+TOMMATH_STORAGE_CLASS int mp_prime_fermat(mp_int *a, mp_int *b, int *result);
+
+/* performs one Miller-Rabin test of "a" using base "b".
+ * Sets result to 0 if composite or 1 if probable prime
+ */
+TOMMATH_STORAGE_CLASS int mp_prime_miller_rabin(mp_int *a, mp_int *b, int *result);
+
+/* This gives [for a given bit size] the number of trials required
+ * such that Miller-Rabin gives a prob of failure lower than 2^-96
+ */
+TOMMATH_STORAGE_CLASS int mp_prime_rabin_miller_trials(int size);
+
+/* performs t rounds of Miller-Rabin on "a" using the first
+ * t prime bases. Also performs an initial sieve of trial
+ * division. Determines if "a" is prime with probability
+ * of error no more than (1/4)**t.
+ *
+ * Sets result to 1 if probably prime, 0 otherwise
+ */
+TOMMATH_STORAGE_CLASS int mp_prime_is_prime(mp_int *a, int t, int *result);
+
+/* finds the next prime after the number "a" using "t" trials
+ * of Miller-Rabin.
+ *
+ * bbs_style = 1 means the prime must be congruent to 3 mod 4
+ */
+TOMMATH_STORAGE_CLASS int mp_prime_next_prime(mp_int *a, int t, int bbs_style);
+
+/* makes a truly random prime of a given size (bytes),
+ * call with bbs = 1 if you want it to be congruent to 3 mod 4
+ *
+ * You have to supply a callback which fills in a buffer with random bytes. "dat" is a parameter you can
+ * have passed to the callback (e.g. a state or something). This function doesn't use "dat" itself
+ * so it can be NULL
+ *
+ * The prime generated will be larger than 2^(8*size).
+ */
+#define mp_prime_random(a, t, size, bbs, cb, dat) mp_prime_random_ex(a, t, ((size) * 8) + 1, (bbs==1)?LTM_PRIME_BBS:0, cb, dat)
+
+/* makes a truly random prime of a given size (bits),
+ *
+ * Flags are as follows:
+ *
+ * LTM_PRIME_BBS - make prime congruent to 3 mod 4
+ * LTM_PRIME_SAFE - make sure (p-1)/2 is prime as well (implies LTM_PRIME_BBS)
+ * LTM_PRIME_2MSB_OFF - make the 2nd highest bit zero
+ * LTM_PRIME_2MSB_ON - make the 2nd highest bit one
+ *
+ * You have to supply a callback which fills in a buffer with random bytes. "dat" is a parameter you can
+ * have passed to the callback (e.g. a state or something). This function doesn't use "dat" itself
+ * so it can be NULL
+ *
+ */
+TOMMATH_STORAGE_CLASS int mp_prime_random_ex(mp_int *a, int t, int size, int flags, ltm_prime_callback cb, void *dat);
+
+/* ---> radix conversion <--- */
+TOMMATH_STORAGE_CLASS int mp_count_bits(mp_int *a);
+
+TOMMATH_STORAGE_CLASS int mp_unsigned_bin_size(mp_int *a);
+TOMMATH_STORAGE_CLASS int mp_read_unsigned_bin(mp_int *a, unsigned char *b, int c);
+TOMMATH_STORAGE_CLASS int mp_to_unsigned_bin(mp_int *a, unsigned char *b);
+
+TOMMATH_STORAGE_CLASS int mp_signed_bin_size(mp_int *a);
+TOMMATH_STORAGE_CLASS int mp_read_signed_bin(mp_int *a, unsigned char *b, int c);
+TOMMATH_STORAGE_CLASS int mp_to_signed_bin(mp_int *a, unsigned char *b);
+
+TOMMATH_STORAGE_CLASS int mp_read_radix(mp_int *a, const char *str, int radix);
+TOMMATH_STORAGE_CLASS int mp_toradix(mp_int *a, char *str, int radix);
+TOMMATH_STORAGE_CLASS int mp_toradix_n(mp_int * a, char *str, int radix, int maxlen);
+TOMMATH_STORAGE_CLASS int mp_radix_size(mp_int *a, int radix, int *size);
+
+TOMMATH_STORAGE_CLASS int mp_fread(mp_int *a, int radix, FILE *stream);
+TOMMATH_STORAGE_CLASS int mp_fwrite(mp_int *a, int radix, FILE *stream);
+
+#define mp_read_raw(mp, str, len) mp_read_signed_bin((mp), (str), (len))
+#define mp_raw_size(mp) mp_signed_bin_size(mp)
+#define mp_toraw(mp, str) mp_to_signed_bin((mp), (str))
+#define mp_read_mag(mp, str, len) mp_read_unsigned_bin((mp), (str), (len))
+#define mp_mag_size(mp) mp_unsigned_bin_size(mp)
+#define mp_tomag(mp, str) mp_to_unsigned_bin((mp), (str))
+
+#define mp_tobinary(M, S) mp_toradix((M), (S), 2)
+#define mp_tooctal(M, S) mp_toradix((M), (S), 8)
+#define mp_todecimal(M, S) mp_toradix((M), (S), 10)
+#define mp_tohex(M, S) mp_toradix((M), (S), 16)
+
+/* lowlevel functions, do not call! */
+TOMMATH_STORAGE_CLASS int s_mp_add(mp_int *a, mp_int *b, mp_int *c);
+TOMMATH_STORAGE_CLASS int s_mp_sub(mp_int *a, mp_int *b, mp_int *c);
+#define s_mp_mul(a, b, c) s_mp_mul_digs(a, b, c, (a)->used + (b)->used + 1)
+TOMMATH_STORAGE_CLASS int fast_s_mp_mul_digs(mp_int *a, mp_int *b, mp_int *c, int digs);
+TOMMATH_STORAGE_CLASS int s_mp_mul_digs(mp_int *a, mp_int *b, mp_int *c, int digs);
+TOMMATH_STORAGE_CLASS int fast_s_mp_mul_high_digs(mp_int *a, mp_int *b, mp_int *c, int digs);
+TOMMATH_STORAGE_CLASS int s_mp_mul_high_digs(mp_int *a, mp_int *b, mp_int *c, int digs);
+TOMMATH_STORAGE_CLASS int fast_s_mp_sqr(mp_int *a, mp_int *b);
+TOMMATH_STORAGE_CLASS int s_mp_sqr(mp_int *a, mp_int *b);
+TOMMATH_STORAGE_CLASS int mp_karatsuba_mul(mp_int *a, mp_int *b, mp_int *c);
+TOMMATH_STORAGE_CLASS int mp_toom_mul(mp_int *a, mp_int *b, mp_int *c);
+TOMMATH_STORAGE_CLASS int mp_karatsuba_sqr(mp_int *a, mp_int *b);
+TOMMATH_STORAGE_CLASS int mp_toom_sqr(mp_int *a, mp_int *b);
+TOMMATH_STORAGE_CLASS int fast_mp_invmod(mp_int *a, mp_int *b, mp_int *c);
+TOMMATH_STORAGE_CLASS int mp_invmod_slow (mp_int * a, mp_int * b, mp_int * c);
+TOMMATH_STORAGE_CLASS int fast_mp_montgomery_reduce(mp_int *a, mp_int *m, mp_digit mp);
+TOMMATH_STORAGE_CLASS int mp_exptmod_fast(mp_int *G, mp_int *X, mp_int *P, mp_int *Y, int mode);
+TOMMATH_STORAGE_CLASS int s_mp_exptmod (mp_int * G, mp_int * X, mp_int * P, mp_int * Y);
+TOMMATH_STORAGE_CLASS void bn_reverse(unsigned char *s, int len);
+
+extern const char *mp_s_rmap;
+
+#ifdef __cplusplus
+ }
+#endif
+
+#endif
+
+