diff options
author | Kevin B Kenny <kennykb@acm.org> | 2005-05-10 18:33:37 (GMT) |
---|---|---|
committer | Kevin B Kenny <kennykb@acm.org> | 2005-05-10 18:33:37 (GMT) |
commit | 76e3b5eed61a674bce7f9c1e18380842dcff3fbf (patch) | |
tree | 2f108341f2c542f48532e6057d79bfa551a4245f /generic | |
parent | 5b510b75ec4a1d6fb55691bcf55dbf4b0b936624 (diff) | |
download | tcl-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')
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 + + |