diff options
43 files changed, 6845 insertions, 3346 deletions
@@ -1,9 +1,54 @@ +2005-10-08 Don Porter <dgp@users.sourceforge.net> + + TIP#237 IMPLEMENTATION + + [kennykb-numerics-branch] Resynchronized with the HEAD; at this + checkpoint [-rkennykb-numerics-branch-20051008], the HEAD and + kennykb-numerics-branch contain identical code. + + [kennykb-numerics-branch] Merge updates from HEAD + + * generic/tclExecute.c: More performance macros and special + handling of the wide integer type for performance on 32-bit + systems. + +2005-10-07 Don Porter <dgp@users.sourceforge.net> + + [kennykb-numerics-branch] + + * generic/tclExecute.c: Macro GetNumberFromObj() is version of + TclGetNumberFromObj() that saves a function call for common uses. + + * generic/tclInt.h: Made #undef NO_WIDE_TYPE the default on + 32-bit systems. Being able to use 64-bit values without leaping + to mp_int should help with performance. + * generic/tclObj.c: Bug fixes in the #undef NO_WIDE_TYPE + * generic/tclExecute.c: configuration. + + * generic/tclExecute.c: Improved performance of comparison opcodes + and bitwise operations and removed yet more dead code. + 2005-10-07 Jeff Hobbs <jeffh@ActiveState.com> * unix/tclUnixFCmd.c (TraverseUnixTree): Adjust 2004-11-11 change to * tests/fCmd.test (fCmd-20.2): account for NFS special files with a readdir rewind threshold. [Bug 1034337] +2005-10-06 Don Porter <dgp@users.sourceforge.net> + + [kennykb-numerics-branch] + + * generic/tclExecute.c: Improved performance of INST_RSHIFT and + INST_LSHIFT. + +2005-10-05 Don Porter <dgp@users.sourceforge.net> + + [kennykb-numerics-branch] + + * generic/tclExecute.c: Improved performance of INST_MULT, INST_DIV, + INST_ADD, and INST_SUB and replaced a "goto... label" with a + "break from loop" in TclIncrObj() and removed some dead code. + 2005-10-05 Andreas Kupries <andreask@activestate.com> * generic/tclPipe.c (TclCreatePipeline): Fixed [SF Tcl Bug @@ -28,6 +73,18 @@ Correct the resizing of the environ array. We assume that we are in full ownership, but that's not correct.[Bug 979640] +2005-10-04 Don Porter <dgp@users.sourceforge.net> + + [kennykb-numerics-branch] + + * generic/tclExecute.c: Updated TclIncrObj() to more efficiently + add native long integers. Also updated IllegalExprOperandType + and the INST_UMINUS, INST_UPLUS, INST_BITNOT, and + INST_TRY_CVT_TO_NUMERIC sections for performance. + + * generic/tclBasic.c: Updated more callers to make use of + TclGetNumberFromObj. Removed some dead code. + 2005-10-04 Jeff Hobbs <jeffh@ActiveState.com> * win/tclWinSerial.c (SerialSetOptionProc): free argv [Bug 1067708] @@ -56,6 +113,17 @@ * generic/tclTimer.c (Tcl_DeleteTimerHandler): bail out early if passed NULL argument. +2005-10-03 Don Porter <dgp@users.sourceforge.net> + + [kennykb-numerics-branch] + + * generic/tclBasic.c: Re-implemented ExprRoundFunc and ExprEntierFunc + to use TclGetNumberFromObj. + + * generic/tclInt.h: Added new routine TclGetNumberFromObj to + * generic/tclObj.c: provide efficient access to the actual + internal rep of a numeric Tcl_Obj without conversions. + 2005-10-03 Kevin Kenny <kennykb@acm.org> * tools/loadICU.tcl: Changed the file names of message catalogs @@ -71,12 +139,29 @@ * generic/tclMain.c: Separate encoding conversion of command line arguments from list formatting. [Bug 1306162]. +2005-09-30 Don Porter <dgp@users.sourceforge.net> + + [kennykb-numerics-branch] + + * generic/tclStringObj.c: Bug fix: Missing cast to large enough + integral size before << operations led to broken [format %llx] results. + Thanks to Robert Henry for reporting the bug. + 2005-09-29 Jeff Hobbs <jeffh@ActiveState.com> * doc/mathfunc.n: implementation for TIP #255, expr min/max * library/init.tcl: * tests/info.test, tests/expr-old.test: +2005-09-27 Don Porter <dgp@users.sourceforge.net> + + [kennykb-numerics-branch] + + * generic/tcl.h: Changed name of the new Tcl_Obj intrep field + * generic/tclObj.c: from "bignumValue" to "ptrAndLongRep" as + * generic/tclProc.c: described in TIP 237, and more suitable for + other more general uses. + 2005-09-27 Donal K. Fellows <donal.k.fellows@manchester.ac.uk> * tests/binary.test (binary-14.18): Added test for [Bug 1116542] @@ -84,11 +169,67 @@ 2005-09-26 Kevin Kenny <kennykb@acm.org> + [kennykb-numerics-branch] Merge updates from HEAD. + +2005-09-26 Kevin Kenny <kennykb@acm.org> + * libtommath/: Updated to release 0.36. * generic/tommath.h: Regenerated. * generic/tclTomMathInterface.h: Added ten missing aliases for mp_* functions to avoid namespace pollution in Tcl's exported symbols. [Bug 1263012] + +2005-09-23 Don Porter <dgp@users.sourceforge.net> + + [kennykb-numerics-branch] + + * unix/Makefile.in: Added -DMP_PREC=4 switch to all compiles so + * win/Makefile.in: that minimum memory requirements of mp_int's + * win/makefile.vc: will not be quite so large. [Bug 1299153]. + + * generic/tclStrToD.c: Fixed memory leak. [Bug 1299803]. + * generic/tclObj.c: + +2005-09-20 Don Porter <dgp@users.sourceforge.net> + + [kennykb-numerics-branch] + + * generic/tclExecute.c: Revise TclIncrObj() to call + Tcl_GetBignumAndClearObj. + + * generic/tcl.decls: Add Tcl_GetBignumAndClearObj. + * generic/tclObj.c: + + * generic/tclDecls.h: make genstubs + * generic/tclStubInit.c: + +2005-09-16 Don Porter <dgp@users.sourceforge.net> + + [kennykb-numerics-branch] + + * generic/tclInt.h: Added TclBNInitBigNumFromWideInt() + * generic/tclTomMathInterface.c: so that every caller isn't + required to duplicate the sign logic to use the unsigned interface. + + * generic/tclBasic.c: Reduce the number of places where Tcl + * generic/tclExecute.c: intrudes into the internal format details + * generic/tclObj.c: of the mp_int struct. + * generic/tclStrToD.c: + * generic/tcLStringObj.c: + + * generic/tclTomMath.h: Added mp_cmp_d to routines from + * unix/Makefile.in: libtommath used by Tcl. + * win/Makefile.in: + * win/makefile.vc: + + * libtommath/bn_mp_add_d.c: Bug fix. For mp_add_d(&a, d, &c), + when &a has the value -d, then the value &c computed should be zero, + but mp_add_d was producing an inconsistent zero value with a sign + field of MP_NEG, something like a value of -0, which other routines + in libtommath can't handle. + + * generic/tclExecute.c: Dropped all creation of "bigOne" values + and just use tommath routines that accept the value "1" directly. 2005-09-15 Miguel Sofer <msofer@users.sf.net> @@ -96,6 +237,8 @@ 2005-09-15 Don Porter <dgp@users.sourceforge.net> + [kennykb-numerics-branch] Merge updates from HEAD. + * generic/tclStringObj.c (TclAppendFormattedObjs): Revision to eliminate one round of string copying. @@ -165,6 +308,11 @@ 2005-09-12 Don Porter <dgp@users.sourceforge.net> + [kennykb-numerics-branch] Merge updates from HEAD. + + * generic/tclCmdAH.c: Added support for the "ll" width + * generic/tclStringObj.c: specifier to [format]. + * generic/tclStringObj.c (TclAppendFormattedObjs): Bug fix: make sure %ld formats force the collection of a wide value, when the value could be a different long. @@ -176,6 +324,10 @@ 1286256]. The other warning can be removed only by removing the panic/return code. +2005-09-09 Don Porter <dgp@users.sourceforge.net> + + [kennykb-numerics-branch] Merge updates from HEAD. + 2005-09-09 Kevin Kenny <kennykb@acm.org> * generic/tclStringObj.c: Added two missing casts to silence @@ -228,6 +380,17 @@ * generic/tclObj.c (pendingObjDataKey): Added missing 'static' to stop symbol from leaking outside the Tcl library. [Bug 1263012] +2005-09-02 Don Porter <dgp@users.sourceforge.net> + + [kennykb-numerics-branch] + + * generic/tclScan.c: Bug fix: The %o, %x, %i formats of [scan] + must not accept any 0b or 0o prefixes. [scan $s %o] must continue + to work even with KILL_OCTAL enabled. + + * generic/tclInt.h: Added TCL_PARSE_SCAN_PREFIXES to the flags + * generic/tclStrToD.c: accepted by TclParseNumber. + 2005-09-01 Andreas Kupries <andreask@activestate.com> * unix/tclUnixSock.c (InitializeHostName): Synchronized use of @@ -252,6 +415,22 @@ * generic/tclIORChan.c (RcNewHandle): Synchronized use of static modifier in declaration and definition of function. +2005-09-01 Don Porter <dgp@users.sourceforge.net> + + [kennykb-numerics-branch] + + * generic/tclObj.c: TclParseNumber calls meant to parse an + integer value now pass the TCL_PARSE_INTEGER_ONLY flag. + + * generic/tclScan.c: Extended [scan] to accept the %lld, + %llo, %llx, and %lli formats. Numeric scanning is now done + via TclParseNumber calls. + + * generic/tclInt.h: Extended TclParseNumber to accept new flag + * generic/tclStrToD.c: values TCL_PARSE_INTEGER_ONLY, + TCL_PARSE_OCTAL_ONLY, and TCL_PARSE_HEXIDECIMAL_ONLY, to give caller + more control over the parsing rules. + 2005-08-31 Vince Darley <vincentdarley@sourceforge.net> * doc/FileSystem.3: @@ -261,12 +440,35 @@ allowed. Tcl's core itself (tclEncoding.c:FillEncodingFileMap()) calls this with a NULL interpreter. +2005-08-30 Don Porter <dgp@users.sourceforge.net> + + [kennykb-numerics-branch] + + * generic/tclObj.c: Extended bignum support to include bignums + so large they will not pack into a Tcl_Obj. When they outgrow Tcl's + string rep length limits, a panic will result. + + * generic/tclTomMath.h: Added mp_sqrt to routines from + * unix/Makefile.in: libtommath used by Tcl. + * win/Makefile.in: + * win/makefile.vc: + + * generic/tclBasic.c: Extended sqrt(.) so that range covers + the entire double range, accepting as many bignums in the domain + as that will allow. + 2005-08-29 Andreas Kupries <andreask@activestate.com> * library/tm.tcl (::tcl::tm::roots): Accepted Don Porter's patch for [Tcl SF Bug 1189657]. Syncs the implementation to the specification (TIP #189). +2005-08-29 Don Porter <dgp@users.sourceforge.net> + + [kennykb-numerics-branch] Merge updates from HEAD. + + * generic/tclBasic.c: Restored round(.) to the Tcl 8.4 rules. + 2005-08-29 Kevin Kenny <kennykb@acm.org> * generic/tclBasic.c (ExprMathFunc): Restored "round away from @@ -302,6 +504,19 @@ duplicated object on the floor, which was a memory leak (and a wrong result too). Thanks to Andreas Kupries for reporting this. +2005-08-25 Don Porter <dgp@users.sourceforge.net> + + [kennykb-numerics-branch] Merge updates from HEAD + + * generic/tclExecute.c: Bug fix. INST_RSHIFT: shift of negative + values produced incorrect results. + + * generic/tclExecute.c: Bug fix. INST_*SHIFT opcodes stack + management. [expr 0<<6] should be 0, not 6. + + * generic/tclBasic.c: Extended the domain of round(.) to all + non-Inf, non-NaN doubles, using bignums for the result as needed. + 2005-08-24 Andreas Kupries <andreask@activestate.com> TIP#219 IMPLEMENTATION @@ -337,6 +552,37 @@ point numbers with the largest and smallest possible significands, and added test cases for them. +2005-08-24 Kevin Kenny <kennykb@users.sourceforge.net> + + [kennykb-numerics-branch] + + * generic/tclExecute.c: Corrected some TRACE bugs that prevented + compilation with --enable-symbols=all. + * generic/tclStrToD.c: Revised commentary to prepare for a + renaming of the file, removed some dead code, and fixed a bug + where TclBignumToDouble failed on huge negative numbers. + * tests/binary.test (binary-65.*): Added missing 'ieeeFloatingPoint' to + large/small significand tests. + * tests/expr.test (expr-45.*) Added missing braces around expressions. + +2005-08-24 Don Porter <dgp@users.sourceforge.net> + + [kennykb-numerics-branch] + + * generic/tclBasic.c: Revised implementation of the ceil(.) and + * generic/tclInt.h: floor(.) math functions in light of the + * generic/tclStrToD.c: revised comparison operators, so that it + is always true that ($x <= ceil($x)) and ($x >= floor($x)). The + simple approach of "convert to double and call ceil() or floor()" + could not guarantee that. + + * generic/tclExecute.c: Bug fix: TclBignumToDouble return -Inf when + appropriate. Removed declarations of removed routines. + + * generic/tclExecute.c: Revised the type promotion rules of the + comparison operators so that they form proper equivalence classes + over the set of numeric strings. + 2005-08-23 Mo DeJong <mdejong@users.sourceforge.net> * unix/configure.in: @@ -344,11 +590,165 @@ * win/configure.in: Update minimum autoconf version to 2.59. +2005-08-23 Kevin Kenny <kennykb@users.sourceforge.net> + + [kennykb-numerics-branch] + + * generic/tclCmdMZ.c (Tcl_StringObjCmd): + * generic/tclInt.h: + * generic/tclObj.c (Tcl_GetBooleanFromObj, SetDoubleFromAny, + Tcl_GetLongFromObj, Tcl_GetWideIntFromObj, Tcl_GetBignumFromObj): + * generic/tclParseExpr.c (GetLexeme): + * generic/tclScan.c (Tcl_ScanObjCmd): + * generic/tclStrToD.c (TclParseNumber): + * tests/binary.test (binary-62.1-65.7): + * tests/expr.test (expr-40.1-42.1): + * scan.test (scan-14.1,14.2): + Modified Tcl_ParseNumber to accept an argument to force + interpretation as decimal, and modified [scan] to use it. + Corrected a bug where Not a Number with hexadecimal information + bits returned consistently incorrect values. #ifdef-ed out + some code that is needed only for IBM hexadecimal floating point. + Fixed bugs in code to handle the corner cases of smallest and + largest significands. Added test cases to improve test coverage + in generic/tclStrToD.c. Added test cases for 0b notation (TIP + #114). Removed TclStrToD, and the static functions that it calls, + which are now dead code (TclParseNumber now does all input + floating-point conversions.) + +2005-08-23 Don Porter <dgp@users.sourceforge.net> + + [kennykb-numerics-branch] + + * generic/tclStrToD.c: Bug fix: set shift magnitude properly whether + we're expanding to mp_int type or not. + + * generic/tclExecute.c: Bug fix: ACCEPT_NAN under INST_UMINUS. + + * generic/tclStrToD.c: New macros TIP_114_FORMATS and KILL_OCTAL to + configure acceptance of 0o and 0b numbers and rejection of "leading + zero as octal". + + * generic/tclBasic.c: Re-used the guts of int(.) and wide(.) math + functions to perform conversions in OldMathFuncProc. + + * generic/tclBasic.c: Support for ACCEPT_NAN. + * generic/tclExecute.c: + + * generic/tclInt.decls: Restored TclExprFloatError to internal stubs + * generic/tclBasic.c: table, and moved definition back to tclExecute.c + * generic/tclExecute.c: from tclBasic.c to handle #undef ACCEPT_NAN. + + * generic/tclIntDecls.h: make genstubs + * generic/tclStubInit.c: + + * generic/tclInt.h: New internal macros TclIsNaN and TclIsInfinite + * generic/tclBasic.c: replace the IS_NAN and IS_INF macros scattered + * generic/tclExecute.c: here and there. + * generic/tclObj.c: + * generic/tclStrToD.c: + * generic/tclUtil.c: + 2005-08-22 Daniel Steffen <das@users.sourceforge.net> * unix/tclConfig.h.in: autoheader-2.59. -cvs2005-08-17 George Peter Staplin <GeorgePS@XMission.com> +2005-08-22 Don Porter <dgp@users.sourceforge.net> + + [kennykb-numerics-branch] + + * generic/tclInt.h: New ACCEPT_NAN macro to mark code that supports + * generic/tclCmdAH.c: or disables accepting of the NaN value at + * generic/tclExecute.c: various points. + * generic/tclLink.c: + + * generic/tclStrToD.c: Bug fix. Parsing of +/- Infinity was reversed. + + * generic/tclTestObj.c: Disabled unused [testconvertobj] command. + + * generic/tclBasic: Added [expr {entier(.)}]. Rewrote int(.) + and wide(.) to use the same guts, accepting all non-Inf doubles as + arguments. + + * generic/tclInt.h: New routine TclInitBignumFromDouble. + * generic/tclStrToD.c: Modified to return code and write error message. + + * generic/tclInt.h: TCL_WIDE_INT_IS_LONG implies NO_WIDE_TYPE. + * generic/tclObj.c: Removed now unnecessary tests of the + * generic/tclStrToD.c: TCL_WIDE_INT_IS_LONG definition. + + * generic/tclInt.h: New internal routine TclSetBignumIntRep + * generic/tclObj.c: consolidates packing of bignum value into + * generic/tclStrToD.c: a Tcl_Obj within one source code file. + + * tests/expr.test: Corrected the wideIs64bit constraint. + * tests/format.test: + * tests/scan.test: + +2005-08-21 Don Porter <dgp@users.sourceforge.net> + + [kennykb-numerics-branch] + + * generic/tclInt.h: Moved TclParseInteger to tclUtil.c + * generic/tclParseExpr.c: and made it static. + * generic/tclUtil.c: + + * generic/tclInt.decls: Moved TclExprFloatError to tclBasic.c and + * generic/tclBasic.c: made it static. + * generic/tclExecute.c: + + * generitc/tclIntDecls.h: make genstubs + * generic/tclStubInit.c: + + * generic/tclExecute.c: errno, IS_NAN, IS_INF, LLD no longer called in + this file; dropped/disabled support for them. + + * generic/tclCompExpr.c: errno no longer used in these files; + * generic/tclParseExpr.c: dropped support "hack" for it. + + * generic/tclStrToD.c: Disabled out of date support "hack" for errno. + + * generic/tclBasic.c: Eliminated VerifyExprObjType. Initialize + errno to zero in OldMathFuncProc. + +2005-08-19 Don Porter <dgp@users.sourceforge.net> + + [kennykb-numerics-branch] + + * generic/tclBasic.c: Updated OldMathFuncProc and ExprAbsFunc to + do less invasion into numeric Tcl_Obj internals. Made ExprDoubleFunc, + ExprIntFunc, ExprWideFunc, and ExprRoundFunc bignum-aware. Revised + ExprSrandFunc error message. + + * generic/tclProc.c: Wrapped a few tclWideIntType uses in + * generic/tclCmdMZ.c: #ifndef NO_WIDE_TYPE. + + * generic/tclInt.h: #define'd NO_WIDE_TYPE. + + * generic/tclVar.c: Replaced TclPtrIncrVar and TclPtrIncrWideVar + * generic/tclInt.h: with TclPtrIncrObjVar and replaced TclIncrVar2 + * generic/tclInt.decls: and TclIncrWideVar2 with TclIncrObjVar2. New + routines call on TclIncrObj to do the work. + + * generic/tclIntDecls.h: make genstubs + * generic/tclStubInit.c: + + * generic/tclCmdIL.c: Rework Tcl_IncrObjCmd and the INST_*INCR* + * generic/tclExecute.c: opcodes to use the new routines. + +2005-08-18 Don Porter <dgp@users.sourceforge.net> + + [kennykb-numerics-branch] + + * generic/tclExecute.c: Fixed string rep invalidation bug in + * tests/dict.test (dict-11.17): INST_DICT_INCR_IMM rewrite. + + * generic/tclDictObj.c: DictIncrCmd rewrite to use TclIncrObj. + + * generic/tclInt.h: TclIncrObj static -> internal + * generic/tclExecute.c: + +2005-08-17 George Peter Staplin <GeorgePS@XMission.com> * generic/tclBasic.c: eliminate a namespace clash caused by BuiltinFuncTable not being static. @@ -365,6 +765,106 @@ cvs2005-08-17 George Peter Staplin <GeorgePS@XMission.com> clock-50.1 into two tests, with a more permissive check on the error message for an out-of-range value. +2005-08-17 Kevin Kenny <kennykb@users.sourceforge.net> + + [kennykb-numerics-branch] + + * generic/tclBasic.c (Tcl_Expr{Long,Double}{,Obj}): Updated to + * generic/tclTest.c: deal with + * tests/expr-old.test: bignums (well, + * tests/expr.test: mostly). + Added a missing "errno=0;" in ExprUnaryFunc so that spurious + error returns aren't detected. + Added test cases for Tcl_Expr* and Tcl_Expr*Obj because + there was very poor test coverage in those areas. + * generic/tclParseExpr.c: Reworked parsing of numbers to call + TclParseNumber rather than trying to do things locally. + * generic/tclStrToD.c: Corrected a comment. Changed so that + *endPtrPtr does not include any trailing whitespace. + +2005-08-17 Don Porter <dgp@users.sourceforge.net> + + [kennykb-numerics-branch] + + * generic/tclExecute.c: New routine TclIncrObj to centralize the + increment operation needed in many places. Updated + INST_DICT_INCR_IMM to make use of it. + +2005-08-16 Don Porter <dgp@users.sourceforge.net> + + [kennykb-numerics-branch] + + * generic/tclExecute.c: Made bit shifting opcodes and INST_MOD + bignum-aware. + + * tests/scan.test: Making << bignum-aware means that repeated + * tests/string.test: left shifting cannot turn a positive into + a negative. Revised [int_range] and [largest_int] utility commands + in the test suite that relied on that happening. Without revision + they became infinite loops. + + * generic/tclExecute.c: Made binary bitwise opcodes bignum-aware. + + * generic/tclTomMath.h: Added mp_or and mp_xor to routines from + * unix/Makefile.in: libtommath used by Tcl. + * win/Makefile.in: + * win/makefile.vc: + +2005-08-15 Don Porter <dgp@users.sourceforge.net> + + [kennykb-numerics-branch] Updates from HEAD. + * generic/tclExecute.c: More revisions to IllegalExprOperandType. + Merged INST_BITNOT with INST_UMINUS and make it bignum-aware + according to the rule: ~a = -a - 1. Disabled unused code and + noted more TODOs. + + * generic/tclInt.decls: Disabled TclLooksLikeInt() and all callers. + * generic/tclUtil.c: + * generic/tclCompCmds.c: + + * generic/tclBasic.c: Rewrite of VerifyExprObjType(). + + * generic/tclIntDecls.h: make genstubs + * generic/tclStubInit.c: + + * generic/tclExecute.c: Updated execution of comparison bytecodes + to be bignum-aware, routing string compares through INST_STR_CMP. + +2005-08-14 Don Porter <dgp@users.sourceforge.net> + + [kennykb-numerics-branch] + + * generic/tclExecute.c: Updated execution of arithmetic bytecodes + to be bignum-aware, and to allow calculations on NaN to produce + a NaN result. INST_UMINUS updated to call mp_neg. + + * generic/tclTomMath.h: Added mp_and, mp_expt_d, and mp_neg to + * unix/Makefile.in: routines from libtommath used by Tcl. + * win/Makefile.in: + * win/makefile.vc: + +2005-08-13 Don Porter <dgp@users.sourceforge.net> + + [kennykb-numerics-branch] + + * generic/tclObj.c: Extended Bignum auto-narrowing to auto-narrow + to tclWideIntType when appropriate; this helps keep things working as + the bytecode execution code is migrated to supporting bignums. + + * generic/tclExecute.c: Major overhaul of IllegalExprOperandType. + Changed several TclNewFooObj() calls to more logically appropriate + ones. Added several TODO comments marking opportunies for future + work. Made more use of the eePtr->constants. Made INST_UMINUS + bignum aware. + +2005-08-12 Don Porter <dgp@users.sourceforge.net> + + [kennykb-numerics-branch] + + * generic/tclExecute.c: Simplify doCondJump. Use eePtr->constants + as result of INST_DICT_NEXT, INST_LAND, and INST_LOR. Separate + INST_LNOT from INST_UMINUS and simplify. + 2004-08-12 Kevin Kenny <kennykb@acm.org> * generic/tclClock.c (MktimeObjCmd): @@ -375,8 +875,25 @@ cvs2005-08-17 George Peter Staplin <GeorgePS@XMission.com> Tcl's time can track system time on Linux even if TZ is not set. Changed ::tcl::clock::Mktime to check for failure, and added a test case that mimics failure but is really success. + +2005-08-11 Don Porter <dgp@users.sourceforge.net> -2005-08-11 Kevin Kenny <kennykb@acm.org> + [kennykb-numerics-branch] + + * generic/tclExecute.c: Rewrite of INST_LAND/INST_LOR to take + advantage of loss of "pure double" issues. Merged INST_UPLUS + with INST_TRY_CVT_TO_NUMERIC and updated to use improved rules + for impure "double"s as well. + + * generic/tclStrToD.c: Restored conditional generation of + tclWideIntType values by TclParseNumber so that Tcl's not + completely broken while bignum calculation support is incomplete. + The NO_WIDE_TYPE macro can be used to disable this. + + * generic/tclBasic.c (ExprAbsFunc): First pass making [expr abs(.)] + bignum-aware. + +2004-08-11 Kevin Kenny <kennykb@acm.org> * generic/tclEvent.c: Eliminated the USE_THREAD_STORAGE * generic/tclInt.h: option (which is on in every build @@ -391,6 +908,24 @@ cvs2005-08-17 George Peter Staplin <GeorgePS@XMission.com> * win/rules.vc: just a little bit cleaner.) * win/tcl.m4: * win/tclWinThrd.c: + +2005-08-10 Don Porter <dgp@users.sourceforge.net> + + [kennykb-numerics-branch] + + * generic/tclTomMath.h: Added mp_shrink, mp_to_unsigned_bin, + * unix/Makefile.in: mp_to_unsigned_bin_n, and mp_unsigned_bin_size + * win/Makefile.in: to routines from libtommath used by Tcl. + * win/makefile.vc: + + * generic/tommath.h: make gentommath_h + + * generic/tclObj.c: Substantial rewrite to make all number + parsing flow through TclParseNumber(). Also established the + NO_WIDE_TYPE and BIGNUM_AUTO_NARROW #ifdef's to help track the + assumptions of different portions of the code. + + * generic/tclInt.h: Added NO_WIDE_TYPE #ifdefs 2005-08-10 Kevin Kenny <kennykb@acm.org> @@ -410,12 +945,24 @@ cvs2005-08-17 George Peter Staplin <GeorgePS@XMission.com> * generic/tclPathObj.c: fix to [file rootname] bug in optimized code path reported on comp.lang.tcl. +2005-08-08 Don Porter <dgp@users.sourceforge.net> + + [kennykb-numerics-branch] + + * generic/tclObj.c: Replaced some goto's with loops and started + use of BIGNUM_AUTO_NARROW and NO_WIDE_TYPE. + 2005-08-06 Donal K. Fellows <donal.k.fellows@man.ac.uk> * generic/tclThreadStorage.c: Stop exposing the guts of the thread storage system through the internal stubs table. Client code should always use the standard API. +2005-08-05 Don Porter <dgp@users.sourceforge.net> + + [kennykb-numerics-branch] + * generic/tclObj.c: Rewrote Tcl_GetDoubleFromObj(). + 2005-08-05 Donal K. Fellows <dkf@users.sf.net> * unix/tclUnixInit.c (localeTable): Solaris uses a non-standard @@ -444,6 +991,12 @@ cvs2005-08-17 George Peter Staplin <GeorgePS@XMission.com> 2005-08-04 Don Porter <dgp@users.sourceforge.net> + [kennykb-numerics-branch] Updated from HEAD + + * generic/tclObj.c: Rewrote Tcl_GetBooleanFromObj() and supporting + routines to make use of TclParseNumber. This reduces the potential + number of times a string value must be scanned. + * generic/tclObj.c: Simplified routines that manage the typeTable. Deleted the UpdateStringOfBoolean() routine, that can never be called. @@ -454,6 +1007,10 @@ cvs2005-08-17 George Peter Staplin <GeorgePS@XMission.com> * generic/tclInt.h: [Bug 1251399] * generic/tclObj.c: +2005-08-02 Don Porter <dgp@users.sourceforge.net> + + [kennykb-numerics-branch] Updated from HEAD + 2005-07-30 Daniel Steffen <das@users.sourceforge.net> * unix/tclLoadDyld.c (TclpDlopen, TclpLoadMemory): workarounds @@ -627,6 +1184,23 @@ cvs2005-08-17 George Peter Staplin <GeorgePS@XMission.com> on Windows to favor GetComputerName() over gethostname() as a source of the information. +2005-07-12 Kevin Kenny <kennykb@acm.org> + + [kennykb-numerics-branch] Updated from HEAD + + * generic/tclCmdMZ.c (Tcl_StringObjCmd): + * generic/tclInt.h: + * generic/tclObj.c (Tcl_GetDoubleFromObj, SetDoubleFromAny, + Tcl_GetIntFromObj, SetIntOrWideFromAny): + * generic/tclStrToD.c (TclParseNumber, etc.): + * tclTomMathInterface.c (TclBNInitBignumFromWideUInt): + * tests/obj.test (obj-1.1, obj-2.2, obj-3.1, obj-3.2): + + Initial attempt at an implementation of TIP #249, comprising + a unified parser and modifications to the Tcl_Get*FromObj + routines to use it. Further integration of the parser is + necessary and planned. + 2005-07-12 Donal K. Fellows <dkf@users.sf.net> * doc/lsearch.n: Clarify documentation of -exact option; wording was @@ -1180,8 +1754,14 @@ cvs2005-08-17 George Peter Staplin <GeorgePS@XMission.com> 2005-05-12 Kevin Kenny <kennykb@acm.org> * doc/mathfunc.n: Changed NAME line to match the name of the page. + +2005-05-11 Kevin Kenny <kennykb@acm.org> -2005-05-11 Kevin Kenny <kennykb@acm.org> + [kennykb-numerics-branch] Resynchronized with the HEAD; at this + checkpoint [-rkennykb-numerics-branch-20050511], the HEAD and + kennykb-numerics-branch contain identical code. + +2005-05-11 Kevin Kenny <kennykb@acm.org> * generic/tclStrToD.c (TclStrToD, RefineResult, ParseNaN): Changed the code to cast 'char' to UCHAR explicitly when diff --git a/generic/tcl.decls b/generic/tcl.decls index b6417ff..3254f2c 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -11,7 +11,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: tcl.decls,v 1.113 2005/08/24 17:56:23 andreas_kupries Exp $ +# RCS: @(#) $Id: tcl.decls,v 1.114 2005/10/08 14:42:44 dgp Exp $ library tcl @@ -2003,28 +2003,31 @@ declare 557 generic { declare 558 generic { int Tcl_GetBignumFromObj( Tcl_Interp* interp, Tcl_Obj* obj, mp_int* value ) } +declare 559 generic { + int Tcl_GetBignumAndClearObj( Tcl_Interp* interp, Tcl_Obj* obj, mp_int* value ) +} # TIP #208: -declare 559 generic { +declare 560 generic { int Tcl_TruncateChannel(Tcl_Channel chan, Tcl_WideInt length) } -declare 560 generic { +declare 561 generic { Tcl_DriverTruncateProc *Tcl_ChannelTruncateProc( Tcl_ChannelType *chanTypePtr) } # TIP#219 (Tcl Channel Reflection API) akupries -declare 561 generic { +declare 562 generic { void Tcl_SetChannelErrorInterp (Tcl_Interp* interp, Tcl_Obj* msg) } -declare 562 generic { +declare 563 generic { void Tcl_GetChannelErrorInterp (Tcl_Interp* interp, Tcl_Obj** msg) } -declare 563 generic { +declare 564 generic { void Tcl_SetChannelError (Tcl_Channel chan, Tcl_Obj* msg) } -declare 564 generic { +declare 565 generic { void Tcl_GetChannelError (Tcl_Channel chan, Tcl_Obj** msg) } diff --git a/generic/tcl.h b/generic/tcl.h index f75ae6f..0d43309 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -13,7 +13,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tcl.h,v 1.203 2005/09/13 21:23:51 dgp Exp $ + * RCS: @(#) $Id: tcl.h,v 1.204 2005/10/08 14:42:44 dgp Exp $ */ #ifndef _TCL @@ -770,10 +770,10 @@ typedef struct Tcl_Obj { } twoPtrValue; struct { /* - internal rep as a wide int, tightly * packed fields */ - VOID *digits; /* Pointer to digits */ - unsigned long misc; /* Alloc, used, and signum packed into a + VOID *ptr; /* Pointer to digits */ + unsigned long value;/* Alloc, used, and signum packed into a * single word */ - } bignumValue; + } ptrAndLongRep; } internalRep; } Tcl_Obj; diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 0198a4e..b2bef10 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -13,13 +13,14 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclBasic.c,v 1.174 2005/09/15 16:40:02 dgp Exp $ + * RCS: @(#) $Id: tclBasic.c,v 1.175 2005/10/08 14:42:44 dgp Exp $ */ #include "tclInt.h" #include "tclCompile.h" #include <float.h> #include <math.h> +#include "tommath.h" /* * The following structure defines the client data for a math function @@ -37,90 +38,48 @@ typedef struct OldMathFuncData { * Static procedures in this file: */ -static char * CallCommandTraces(Interp *iPtr, Command *cmdPtr, +static char * CallCommandTraces (Interp *iPtr, Command *cmdPtr, CONST char *oldName, CONST char* newName, int flags); -static void DeleteInterpProc(Tcl_Interp *interp); -static void ProcessUnexpectedResult(Tcl_Interp *interp, int returnCode); +static int CheckDoubleResult (Tcl_Interp *interp, double dResult); +static void DeleteInterpProc (Tcl_Interp *interp); +static void ProcessUnexpectedResult (Tcl_Interp *interp, int returnCode); -static int OldMathFuncProc(ClientData clientData, Tcl_Interp *interp, +static int OldMathFuncProc (ClientData clientData, Tcl_Interp *interp, int argc, Tcl_Obj *CONST *objv); -static void OldMathFuncDeleteProc(ClientData clientData); +static void OldMathFuncDeleteProc (ClientData clientData); -static int ExprAbsFunc(ClientData clientData, Tcl_Interp *interp, +static int ExprAbsFunc (ClientData clientData, Tcl_Interp *interp, int argc, Tcl_Obj *CONST *objv); -static int ExprBinaryFunc(ClientData clientData, Tcl_Interp *interp, +static int ExprBinaryFunc (ClientData clientData, Tcl_Interp *interp, int argc, Tcl_Obj *CONST *objv); -static int ExprBoolFunc(ClientData clientData, Tcl_Interp *interp, +static int ExprBoolFunc (ClientData clientData, Tcl_Interp *interp, int argc, Tcl_Obj *CONST *objv); -static int ExprDoubleFunc(ClientData clientData, Tcl_Interp *interp, +static int ExprCeilFunc (ClientData clientData, Tcl_Interp *interp, int argc, Tcl_Obj *CONST *objv); -static int ExprIntFunc(ClientData clientData, Tcl_Interp *interp, +static int ExprDoubleFunc (ClientData clientData, Tcl_Interp *interp, int argc, Tcl_Obj *CONST *objv); -static int ExprRandFunc(ClientData clientData, Tcl_Interp *interp, +static int ExprEntierFunc (ClientData clientData, Tcl_Interp *interp, int argc, Tcl_Obj *CONST *objv); -static int ExprRoundFunc(ClientData clientData, Tcl_Interp *interp, +static int ExprFloorFunc (ClientData clientData, Tcl_Interp *interp, int argc, Tcl_Obj *CONST *objv); -static int ExprSrandFunc(ClientData clientData, Tcl_Interp *interp, +static int ExprIntFunc (ClientData clientData, Tcl_Interp *interp, int argc, Tcl_Obj *CONST *objv); -static int ExprUnaryFunc(ClientData clientData, Tcl_Interp *interp, +static int ExprRandFunc (ClientData clientData, Tcl_Interp *interp, int argc, Tcl_Obj *CONST *objv); -static int ExprWideFunc(ClientData clientData, Tcl_Interp *interp, +static int ExprRoundFunc (ClientData clientData, Tcl_Interp *interp, int argc, Tcl_Obj *CONST *objv); -static int VerifyExprObjType(Tcl_Interp *interp, Tcl_Obj *objPtr); - -static void MathFuncWrongNumArgs(Tcl_Interp* interp, int expected, +static int ExprSqrtFunc (ClientData clientData, Tcl_Interp *interp, + int argc, Tcl_Obj *CONST *objv); +static int ExprSrandFunc (ClientData clientData, Tcl_Interp *interp, + int argc, Tcl_Obj *CONST *objv); +static int ExprUnaryFunc (ClientData clientData, Tcl_Interp *interp, + int argc, Tcl_Obj *CONST *objv); +static int ExprWideFunc (ClientData clientData, Tcl_Interp *interp, + int argc, Tcl_Obj *CONST *objv); +static void MathFuncWrongNumArgs (Tcl_Interp* interp, int expected, int actual, Tcl_Obj *CONST *objv); -#ifndef TCL_WIDE_INT_IS_LONG -/* - * Extract a double value from a general numeric object. - */ - -#define GET_DOUBLE_VALUE(doubleVar, objPtr, typePtr) \ - if ((typePtr) == &tclIntType) { \ - (doubleVar) = (double) (objPtr)->internalRep.longValue; \ - } else if ((typePtr) == &tclWideIntType) { \ - (doubleVar) = Tcl_WideAsDouble((objPtr)->internalRep.wideValue);\ - } else { \ - (doubleVar) = (objPtr)->internalRep.doubleValue; \ - } -#else /* TCL_WIDE_INT_IS_LONG */ -#define GET_DOUBLE_VALUE(doubleVar, objPtr, typePtr) \ - if (((typePtr) == &tclIntType) || ((typePtr) == &tclWideIntType)) { \ - (doubleVar) = (double) (objPtr)->internalRep.longValue; \ - } else { \ - (doubleVar) = (objPtr)->internalRep.doubleValue; \ - } -#endif /* TCL_WIDE_INT_IS_LONG */ -#define GET_WIDE_OR_INT(resultVar, objPtr, longVar, wideVar) \ - (resultVar) = Tcl_GetWideIntFromObj((Tcl_Interp *) NULL, (objPtr), \ - &(wideVar)); \ - if ((resultVar) == TCL_OK && (wideVar) >= Tcl_LongAsWide(LONG_MIN) \ - && (wideVar) <= Tcl_LongAsWide(LONG_MAX)) { \ - (objPtr)->typePtr = &tclIntType; \ - (objPtr)->internalRep.longValue = (longVar) \ - = Tcl_WideAsLong(wideVar); \ - } -#define IS_INTEGER_TYPE(typePtr) \ - ((typePtr) == &tclIntType || (typePtr) == &tclWideIntType) -#define IS_NUMERIC_TYPE(typePtr) \ - (IS_INTEGER_TYPE(typePtr) || (typePtr) == &tclDoubleType) - -/* - * Macros for testing floating-point values for certain special cases. Test - * for not-a-number by comparing a value against itself; test for infinity by - * comparing against the largest floating-point value. - */ - -#ifdef _MSC_VER -#define IS_NAN(f) (_isnan((f))) -#define IS_INF(f) (!(_finite((f)))) -#else -#define IS_NAN(f) ((f) != (f)) -#define IS_INF(f) (((f) > DBL_MAX) || ((f) < -DBL_MAX)) -#endif - extern TclStubs tclStubs; /* @@ -251,12 +210,13 @@ static BuiltinFuncDef BuiltinFuncTable[] = { { "::tcl::mathfunc::atan", ExprUnaryFunc, (ClientData) atan }, { "::tcl::mathfunc::atan2", ExprBinaryFunc, (ClientData) atan2 }, { "::tcl::mathfunc::bool", ExprBoolFunc, NULL }, - { "::tcl::mathfunc::ceil", ExprUnaryFunc, (ClientData) ceil }, + { "::tcl::mathfunc::ceil", ExprCeilFunc, NULL }, { "::tcl::mathfunc::cos", ExprUnaryFunc, (ClientData) cos }, { "::tcl::mathfunc::cosh", ExprUnaryFunc, (ClientData) cosh }, { "::tcl::mathfunc::double",ExprDoubleFunc, NULL }, + { "::tcl::mathfunc::entier",ExprEntierFunc, NULL }, { "::tcl::mathfunc::exp", ExprUnaryFunc, (ClientData) exp }, - { "::tcl::mathfunc::floor", ExprUnaryFunc, (ClientData) floor }, + { "::tcl::mathfunc::floor", ExprFloorFunc, NULL }, { "::tcl::mathfunc::fmod", ExprBinaryFunc, (ClientData) fmod }, { "::tcl::mathfunc::hypot", ExprBinaryFunc, (ClientData) hypot }, { "::tcl::mathfunc::int", ExprIntFunc, NULL }, @@ -267,7 +227,7 @@ static BuiltinFuncDef BuiltinFuncTable[] = { { "::tcl::mathfunc::round", ExprRoundFunc, NULL }, { "::tcl::mathfunc::sin", ExprUnaryFunc, (ClientData) sin }, { "::tcl::mathfunc::sinh", ExprUnaryFunc, (ClientData) sinh }, - { "::tcl::mathfunc::sqrt", ExprUnaryFunc, (ClientData) sqrt }, + { "::tcl::mathfunc::sqrt", ExprSqrtFunc, NULL }, { "::tcl::mathfunc::srand", ExprSrandFunc, NULL }, { "::tcl::mathfunc::tan", ExprUnaryFunc, (ClientData) tan }, { "::tcl::mathfunc::tanh", ExprUnaryFunc, (ClientData) tanh }, @@ -2873,7 +2833,10 @@ OldMathFuncProc(clientData, interp, objc, objv) Tcl_Value args[MAX_MATH_ARGS]; Tcl_Value funcResult; int result; - int i, j, k; +#if 0 + int i; +#endif + int j, k; double d; /* @@ -2889,6 +2852,7 @@ OldMathFuncProc(clientData, interp, objc, objv) * Convert arguments from Tcl_Obj's to Tcl_Value's. */ +#if 0 for (j = 1, k = 0; j < objc; ++j, ++k) { valuePtr = objv[j]; if (VerifyExprObjType(interp, valuePtr) != TCL_OK) { @@ -2939,11 +2903,75 @@ OldMathFuncProc(clientData, interp, objc, objv) } } } +#else + for (j = 1, k = 0; j < objc; ++j, ++k) { + valuePtr = objv[j]; + result = Tcl_GetDoubleFromObj(NULL, valuePtr, &d); +#ifdef ACCEPT_NAN + if ((result != TCL_OK) && (valuePtr->typePtr == &tclDoubleType)) { + d = valuePtr->internalRep.doubleValue; + result = TCL_OK; + } +#endif + if (result != TCL_OK) { + /* Non-numeric argument */ + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "argument to math function didn't have numeric value", -1)); + TclCheckBadOctal(interp, Tcl_GetString(valuePtr)); + return TCL_ERROR; + } + + /* + * Copy the object's numeric value to the argument record, + * converting it if necessary. + * + * NOTE: no bignum support; use the new mathfunc interface for that + */ + + args[k].type = dataPtr->argTypes[k]; + switch (args[k].type) { + case TCL_EITHER: + if (Tcl_GetLongFromObj(NULL, valuePtr, &(args[k].intValue)) + == TCL_OK) { + args[k].type = TCL_INT; + break; + } + if (Tcl_GetWideIntFromObj(interp, valuePtr, &(args[k].wideValue)) + == TCL_OK) { + args[k].type = TCL_WIDE_INT; + break; + } + args[k].type = TCL_DOUBLE; + /* FALLTHROUGH */ + + case TCL_DOUBLE: + args[k].doubleValue = d; + break; + case TCL_INT: + if (ExprIntFunc(NULL, interp, 2, &(objv[j-1])) != TCL_OK) { + return TCL_ERROR; + } + valuePtr = Tcl_GetObjResult(interp); + Tcl_GetLongFromObj(NULL, valuePtr, &(args[k].intValue)); + Tcl_ResetResult(interp); + break; + case TCL_WIDE_INT: + if (ExprWideFunc(NULL, interp, 2, &(objv[j-1])) != TCL_OK) { + return TCL_ERROR; + } + valuePtr = Tcl_GetObjResult(interp); + Tcl_GetWideIntFromObj(NULL, valuePtr, &(args[k].wideValue)); + Tcl_ResetResult(interp); + break; + } + } +#endif /* * Call the function. */ + errno = 0; result = (*dataPtr->proc)(dataPtr->clientData, interp, args, &funcResult); if (result != TCL_OK) { return result; @@ -2956,18 +2984,12 @@ OldMathFuncProc(clientData, interp, objc, objv) if (funcResult.type == TCL_INT) { TclNewLongObj(valuePtr, funcResult.intValue); } else if (funcResult.type == TCL_WIDE_INT) { - TclNewWideIntObj(valuePtr, funcResult.wideValue); + valuePtr = Tcl_NewWideIntObj(funcResult.wideValue); } else { - d = funcResult.doubleValue; - if (IS_NAN(d) || IS_INF(d)) { - TclExprFloatError(interp, d); - return TCL_ERROR; - } - TclNewDoubleObj(valuePtr, d); + return CheckDoubleResult(interp, funcResult.doubleValue); } Tcl_SetObjResult(interp, valuePtr); return TCL_OK; - } /* @@ -4191,64 +4213,18 @@ Tcl_ExprLong(interp, exprstring, ptr) long *ptr; /* Where to store result. */ { register Tcl_Obj *exprPtr; - Tcl_Obj *resultPtr; - int length = strlen(exprstring); int result = TCL_OK; - - if (length > 0) { - exprPtr = Tcl_NewStringObj(exprstring, length); + if (*exprstring == '\0') { + /* Legacy compatibility - return 0 for the zero-length string. */ + *ptr = 0; + } else { + exprPtr = Tcl_NewStringObj(exprstring, -1); Tcl_IncrRefCount(exprPtr); - result = Tcl_ExprObj(interp, exprPtr, &resultPtr); - if (result == TCL_OK) { - /* - * Store an integer based on the expression result. - */ - - if (resultPtr->typePtr == &tclIntType) { - *ptr = resultPtr->internalRep.longValue; - } else if (resultPtr->typePtr == &tclDoubleType) { - *ptr = (long) resultPtr->internalRep.doubleValue; - } else if (resultPtr->typePtr == &tclWideIntType) { -#ifndef TCL_WIDE_INT_IS_LONG - /* - * See Tcl_GetIntFromObj for conversion comments. - */ - - Tcl_WideInt w = resultPtr->internalRep.wideValue; - - if ((w >= -(Tcl_WideInt)(ULONG_MAX)) - && (w <= (Tcl_WideInt)(ULONG_MAX))) { - *ptr = Tcl_WideAsLong(w); - } else { - Tcl_SetResult(interp, - "integer value too large to represent as non-long integer", - TCL_STATIC); - result = TCL_ERROR; - } -#else - *ptr = resultPtr->internalRep.longValue; -#endif - } else { - Tcl_SetResult(interp, - "expression didn't have numeric value", TCL_STATIC); - result = TCL_ERROR; - } - Tcl_DecrRefCount(resultPtr);/* discard the result object */ - } else { - /* - * Move the interpreter's object result to the string result, then - * reset the object result. - */ - + result = Tcl_ExprLongObj(interp, exprPtr, ptr); + Tcl_DecrRefCount(exprPtr); + if (result != TCL_OK) { (void) Tcl_GetStringResult(interp); } - Tcl_DecrRefCount(exprPtr); /* discard the expression object */ - } else { - /* - * An empty string. Just set the result integer to 0. - */ - - *ptr = 0; } return result; } @@ -4261,64 +4237,19 @@ Tcl_ExprDouble(interp, exprstring, ptr) double *ptr; /* Where to store result. */ { register Tcl_Obj *exprPtr; - Tcl_Obj *resultPtr; - int length = strlen(exprstring); int result = TCL_OK; - if (length > 0) { - exprPtr = Tcl_NewStringObj(exprstring, length); + if (*exprstring == '\0') { + /* Legacy compatibility - return 0 for the zero-length string. */ + *ptr = 0.0; + } else { + exprPtr = Tcl_NewStringObj(exprstring, -1); Tcl_IncrRefCount(exprPtr); - result = Tcl_ExprObj(interp, exprPtr, &resultPtr); - if (result == TCL_OK) { - /* - * Store a double based on the expression result. - */ - - if (resultPtr->typePtr == &tclIntType) { - *ptr = (double) resultPtr->internalRep.longValue; - } else if (resultPtr->typePtr == &tclDoubleType) { - *ptr = resultPtr->internalRep.doubleValue; - } else if (resultPtr->typePtr == &tclWideIntType) { -#ifndef TCL_WIDE_INT_IS_LONG - /* - * See Tcl_GetIntFromObj for conversion comments. - */ - - Tcl_WideInt w = resultPtr->internalRep.wideValue; - - if ((w >= -(Tcl_WideInt)(ULONG_MAX)) - && (w <= (Tcl_WideInt)(ULONG_MAX))) { - *ptr = (double) Tcl_WideAsLong(w); - } else { - Tcl_SetResult(interp, - "integer value too large to represent as non-long integer", - TCL_STATIC); - result = TCL_ERROR; - } -#else - *ptr = (double) resultPtr->internalRep.longValue; -#endif - } else { - Tcl_SetResult(interp, - "expression didn't have numeric value", TCL_STATIC); - result = TCL_ERROR; - } - Tcl_DecrRefCount(resultPtr);/* discard the result object */ - } else { - /* - * Move the interpreter's object result to the string result, then - * reset the object result. - */ - + result = Tcl_ExprDoubleObj(interp, exprPtr, ptr); + Tcl_DecrRefCount(exprPtr); /* discard the expression object */ + if (result != TCL_OK) { (void) Tcl_GetStringResult(interp); } - Tcl_DecrRefCount(exprPtr); /* discard the expression object */ - } else { - /* - * An empty string. Just set the result double to 0.0. - */ - - *ptr = 0.0; } return result; } @@ -4385,22 +4316,42 @@ Tcl_ExprLongObj(interp, objPtr, ptr) long *ptr; /* Where to store long result. */ { Tcl_Obj *resultPtr; - int result; + int result, type; + double d; + ClientData internalPtr; result = Tcl_ExprObj(interp, objPtr, &resultPtr); - if (result == TCL_OK) { - if (resultPtr->typePtr == &tclIntType) { - *ptr = resultPtr->internalRep.longValue; - } else if (resultPtr->typePtr == &tclDoubleType) { - *ptr = (long) resultPtr->internalRep.doubleValue; - } else { - result = Tcl_GetLongFromObj(interp, resultPtr, ptr); - if (result != TCL_OK) { - return result; - } + if (result != TCL_OK) { + return TCL_ERROR; + } + + if (TclGetNumberFromObj(interp, resultPtr, &internalPtr, &type) != TCL_OK) { + return TCL_ERROR; + } + + switch (type) { + case TCL_NUMBER_DOUBLE: { + mp_int big; + d = *((CONST double *)internalPtr); + Tcl_DecrRefCount(resultPtr); + if (TclInitBignumFromDouble(interp, d, &big) != TCL_OK) { + return TCL_ERROR; } - Tcl_DecrRefCount(resultPtr); /* discard the result object */ + resultPtr = Tcl_NewBignumObj(&big); + /* FALLTHROUGH */ } + case TCL_NUMBER_LONG: + case TCL_NUMBER_WIDE: + case TCL_NUMBER_BIG: + result = Tcl_GetLongFromObj(interp, resultPtr, ptr); + break; + + case TCL_NUMBER_NAN: + Tcl_GetDoubleFromObj(interp, resultPtr, &d); + result = TCL_ERROR; + } + + Tcl_DecrRefCount(resultPtr); /* discard the result object */ return result; } @@ -4412,22 +4363,31 @@ Tcl_ExprDoubleObj(interp, objPtr, ptr) double *ptr; /* Where to store double result. */ { Tcl_Obj *resultPtr; - int result; + int result, type; + ClientData internalPtr; result = Tcl_ExprObj(interp, objPtr, &resultPtr); + if (result != TCL_OK) { + return TCL_ERROR; + } + + result = TclGetNumberFromObj(interp, resultPtr, &internalPtr, &type); if (result == TCL_OK) { - if (resultPtr->typePtr == &tclIntType) { - *ptr = (double) resultPtr->internalRep.longValue; - } else if (resultPtr->typePtr == &tclDoubleType) { - *ptr = resultPtr->internalRep.doubleValue; - } else { - result = Tcl_GetDoubleFromObj(interp, resultPtr, ptr); - if (result != TCL_OK) { - return result; - } + switch (type) { + case TCL_NUMBER_NAN: +#ifndef ACCEPT_NAN + result = Tcl_GetDoubleFromObj( interp, resultPtr, ptr ); + break; +#endif + case TCL_NUMBER_DOUBLE: + *ptr = *((CONST double *)internalPtr); + result = TCL_OK; + break; + default: + result = Tcl_GetDoubleFromObj( interp, resultPtr, ptr ); } - Tcl_DecrRefCount(resultPtr); /* discard the result object */ } + Tcl_DecrRefCount(resultPtr); /* discard the result object */ return result; } @@ -5008,45 +4968,168 @@ Tcl_GetVersion(majorV, minorV, patchLevelV, type) */ static int -ExprUnaryFunc(clientData, interp, objc, objv) - ClientData clientData; /* Contains the address of a procedure that - * takes one double argument and returns a - * double result. */ +ExprCeilFunc(clientData, interp, objc, objv) + ClientData clientData; /* Ignored */ Tcl_Interp *interp; /* The interpreter in which to execute the * function. */ int objc; /* Actual parameter count */ Tcl_Obj *CONST *objv; /* Actual parameter list */ { - double d, dResult; - Tcl_Obj* oResult; + int code; + double d; + mp_int big; - double (*func)(double) = (double (*)(double)) clientData; + if (objc != 2) { + MathFuncWrongNumArgs(interp, 2, objc, objv); + return TCL_ERROR; + } + code = Tcl_GetDoubleFromObj(interp, objv[1], &d); +#ifdef ACCEPT_NAN + if ((code != TCL_OK) && (objv[1]->typePtr == &tclDoubleType)) { + Tcl_SetObjResult(interp, objv[1]); + return TCL_OK; + } +#endif + if (code != TCL_OK) { + return TCL_ERROR; + } + if (Tcl_GetBignumFromObj(NULL, objv[1], &big) == TCL_OK) { + Tcl_SetObjResult(interp, Tcl_NewDoubleObj(TclCeil(&big))); + mp_clear(&big); + } else { + Tcl_SetObjResult(interp, Tcl_NewDoubleObj(ceil(d))); + } + return TCL_OK; +} - /* - * Convert the function's argument to a double if necessary. - */ +static int +ExprFloorFunc(clientData, interp, objc, objv) + ClientData clientData; /* Ignored */ + Tcl_Interp *interp; /* The interpreter in which to execute the + * function. */ + int objc; /* Actual parameter count */ + Tcl_Obj *CONST *objv; /* Actual parameter list */ +{ + int code; + double d; + mp_int big; if (objc != 2) { MathFuncWrongNumArgs(interp, 2, objc, objv); - } else if (Tcl_GetDoubleFromObj(interp, objv[1], &d) == TCL_OK) { + return TCL_ERROR; + } + code = Tcl_GetDoubleFromObj(interp, objv[1], &d); +#ifdef ACCEPT_NAN + if ((code != TCL_OK) && (objv[1]->typePtr == &tclDoubleType)) { + Tcl_SetObjResult(interp, objv[1]); + return TCL_OK; + } +#endif + if (code != TCL_OK) { + return TCL_ERROR; + } + if (Tcl_GetBignumFromObj(NULL, objv[1], &big) == TCL_OK) { + Tcl_SetObjResult(interp, Tcl_NewDoubleObj(TclFloor(&big))); + mp_clear(&big); + } else { + Tcl_SetObjResult(interp, Tcl_NewDoubleObj(floor(d))); + } + return TCL_OK; +} - /* - * Evaluate the function. - */ +static int +ExprSqrtFunc(clientData, interp, objc, objv) + ClientData clientData; /* Ignored */ + Tcl_Interp *interp; /* The interpreter in which to execute the + * function. */ + int objc; /* Actual parameter count */ + Tcl_Obj *CONST *objv; /* Actual parameter list */ +{ + int code; + double d; + mp_int big; - dResult = (*func)(d); - if ((errno != 0) || IS_NAN(dResult)) { - if (errno != ERANGE || (dResult != 0.0 && !IS_INF(dResult))) { - TclExprFloatError(interp, dResult); - return TCL_ERROR; - } - } - TclNewDoubleObj(oResult, dResult); - Tcl_SetObjResult(interp, oResult); + if (objc != 2) { + MathFuncWrongNumArgs(interp, 2, objc, objv); + return TCL_ERROR; + } + code = Tcl_GetDoubleFromObj(interp, objv[1], &d); +#ifdef ACCEPT_NAN + if ((code != TCL_OK) && (objv[1]->typePtr == &tclDoubleType)) { + Tcl_SetObjResult(interp, objv[1]); return TCL_OK; } +#endif + if (code != TCL_OK) { + return TCL_ERROR; + } + if (d >= 0.0 && TclIsInfinite(d) + && Tcl_GetBignumFromObj(NULL, objv[1], &big) == TCL_OK) { + mp_int root; + mp_init(&root); + mp_sqrt(&big, &root); + mp_clear(&big); + Tcl_SetObjResult(interp, Tcl_NewDoubleObj(TclBignumToDouble(&root))); + mp_clear(&root); + } else { + Tcl_SetObjResult(interp, Tcl_NewDoubleObj(sqrt(d))); + } + return TCL_OK; +} - return TCL_ERROR; +static int +ExprUnaryFunc(clientData, interp, objc, objv) + ClientData clientData; /* Contains the address of a procedure that + * takes one double argument and returns a + * double result. */ + Tcl_Interp *interp; /* The interpreter in which to execute the + * function. */ + int objc; /* Actual parameter count */ + Tcl_Obj *CONST *objv; /* Actual parameter list */ +{ + int code; + double d; + double (*func)(double) = (double (*)(double)) clientData; + + if (objc != 2) { + MathFuncWrongNumArgs(interp, 2, objc, objv); + return TCL_ERROR; + } + code = Tcl_GetDoubleFromObj(interp, objv[1], &d); +#ifdef ACCEPT_NAN + if ((code != TCL_OK) && (objv[1]->typePtr == &tclDoubleType)) { + d = objv[1]->internalRep.doubleValue; + Tcl_ResetResult(interp); + code = TCL_OK; + } +#endif + if (code != TCL_OK) { + return TCL_ERROR; + } + errno = 0; + return CheckDoubleResult(interp, (*func)(d)); +} + +static int +CheckDoubleResult(interp, dResult) + Tcl_Interp *interp; + double dResult; +{ +#ifndef ACCEPT_NAN + if (TclIsNaN(dResult)) { + TclExprFloatError(interp, dResult); + return TCL_ERROR; + } +#endif + if ((errno == ERANGE) && ((dResult == 0.0) || TclIsInfinite(dResult))) { + /* When ERANGE signals under/overflow, just accept 0.0 or +/-Inf */ + } else if (errno != 0) { + /* Report other errno values as errors */ + TclExprFloatError(interp, dResult); + return TCL_ERROR; + } + Tcl_SetObjResult(interp, Tcl_NewDoubleObj(dResult)); + return TCL_OK; } static int @@ -5059,38 +5142,38 @@ ExprBinaryFunc(clientData, interp, objc, objv) int objc; /* Actual parameter count */ Tcl_Obj *CONST *objv; /* Parameter vector */ { - double d1, d2, dResult; - Tcl_Obj* oResult; - + int code; + double d1, d2; double (*func)(double, double) = (double (*)(double, double)) clientData; - /* - * Convert the function's two arguments to doubles if necessary. - */ - if (objc != 3) { MathFuncWrongNumArgs(interp, 3, objc, objv); - } else if (Tcl_GetDoubleFromObj(interp, objv[1], &d1) == TCL_OK - && Tcl_GetDoubleFromObj(interp, objv[2], &d2) == TCL_OK) { - /* - * Evaluate the function. - */ - - errno = 0; - dResult = (*func)(d1, d2); - if ((errno != 0) || IS_NAN(dResult)) { - if (errno != ERANGE || (dResult != 0.0 && !IS_INF(dResult))) { - TclExprFloatError(interp, dResult); - return TCL_ERROR; - } - } - TclNewDoubleObj(oResult, dResult); - Tcl_SetObjResult(interp, oResult); - return TCL_OK; + return TCL_ERROR; + } + code = Tcl_GetDoubleFromObj(interp, objv[1], &d1); +#ifdef ACCEPT_NAN + if ((code != TCL_OK) && (objv[1]->typePtr == &tclDoubleType)) { + d1 = objv[1]->internalRep.doubleValue; + Tcl_ResetResult(interp); + code = TCL_OK; } - - return TCL_ERROR; - +#endif + if (code != TCL_OK) { + return TCL_ERROR; + } + code = Tcl_GetDoubleFromObj(interp, objv[2], &d2); +#ifdef ACCEPT_NAN + if ((code != TCL_OK) && (objv[2]->typePtr == &tclDoubleType)) { + d2 = objv[2]->internalRep.doubleValue; + Tcl_ResetResult(interp); + code = TCL_OK; + } +#endif + if (code != TCL_OK) { + return TCL_ERROR; + } + errno = 0; + return CheckDoubleResult(interp, (*func)(d1, d2)); } static int @@ -5101,84 +5184,82 @@ ExprAbsFunc(clientData, interp, objc, objv) int objc; /* Actual parameter count */ Tcl_Obj *CONST *objv; /* Parameter vector */ { - register Tcl_Obj *valuePtr; - long i, iResult; - double d, dResult; - Tcl_Obj* oResult; + ClientData ptr; + int type; + mp_int big; if (objc != 2) { MathFuncWrongNumArgs(interp, 2, objc, objv); return TCL_ERROR; } - valuePtr = objv[1]; - if (VerifyExprObjType(interp, valuePtr) != TCL_OK) { + if (TclGetNumberFromObj(interp, objv[1], &ptr, &type) != TCL_OK) { return TCL_ERROR; } - /* - * Derive the absolute value according to the arg type. - */ - - if (valuePtr->typePtr == &tclIntType) { - i = valuePtr->internalRep.longValue; - if (i < 0) { - iResult = -i; - if (iResult < 0) { -#ifdef TCL_WIDE_INT_IS_LONG - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "integer value too large to represent", -1)); - Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", - "integer value too large to represent", (char *) NULL); - return TCL_ERROR; -#else - /* - * Special case: abs(MIN_INT) must promote to wide. - */ - TclNewWideIntObj(oResult, -(Tcl_WideInt) i); - Tcl_SetObjResult(interp, oResult); - return TCL_OK; -#endif + if (type == TCL_NUMBER_LONG) { + long l = *((CONST long int *)ptr); + if (l < (long)0) { + if (l == LONG_MIN) { + TclBNInitBignumFromLong(&big, l); + goto tooLarge; } + Tcl_SetObjResult(interp, Tcl_NewLongObj(-l)); } else { - iResult = i; + Tcl_SetObjResult(interp, objv[1]); } - TclNewLongObj(oResult, iResult); - Tcl_SetObjResult(interp, oResult); - } else if (valuePtr->typePtr == &tclWideIntType) { - Tcl_WideInt wResult, w; + return TCL_OK; + } - TclGetWide(w, valuePtr); + if (type == TCL_NUMBER_DOUBLE) { + double d = *((CONST double *)ptr); + if (d < 0.0) { + Tcl_SetObjResult(interp, Tcl_NewDoubleObj(-d)); + } else { + Tcl_SetObjResult(interp, objv[1]); + } + return TCL_OK; + } + +#ifndef NO_WIDE_TYPE + if (type == TCL_NUMBER_WIDE) { + Tcl_WideInt w = *((CONST Tcl_WideInt *)ptr); if (w < (Tcl_WideInt)0) { - wResult = -w; - if (wResult < 0) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "integer value too large to represent", -1)); - Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", - "integer value too large to represent", (char *) NULL); - return TCL_ERROR; + if (w == LLONG_MIN) { + TclBNInitBignumFromWideInt(&big, w); + goto tooLarge; } + Tcl_SetObjResult(interp, Tcl_NewWideIntObj(-w)); } else { - wResult = w; + Tcl_SetObjResult(interp, objv[1]); } - TclNewWideIntObj(oResult, wResult); - Tcl_SetObjResult(interp, oResult); - } else { - d = valuePtr->internalRep.doubleValue; - if (d < 0.0) { - dResult = -d; + return TCL_OK; + } +#endif + + if (type == TCL_NUMBER_BIG) { + /* TODO: const correctness ? */ + if (mp_cmp_d((mp_int *)ptr, 0) == MP_LT) { + Tcl_GetBignumFromObj(NULL, objv[1], &big); + tooLarge: + mp_neg(&big, &big); + Tcl_SetObjResult(interp, Tcl_NewBignumObj(&big)); } else { - dResult = d; - } - if (IS_NAN(dResult)) { - TclExprFloatError(interp, dResult); - return TCL_ERROR; + Tcl_SetObjResult(interp, objv[1]); } - TclNewDoubleObj(oResult, dResult); - Tcl_SetObjResult(interp, oResult); + return TCL_OK; } - return TCL_OK; + if (type == TCL_NUMBER_NAN) { +#ifdef ACCEPT_NAN + Tcl_SetObjResult(interp, objv[1]); + return TCL_OK; +#else + double d; + Tcl_GetDoubleFromObj(interp, objv[1], &d); + return TCL_ERROR; +#endif + } } static int @@ -5210,8 +5291,9 @@ ExprDoubleFunc(clientData, interp, objc, objv) int objc; /* Actual parameter count */ Tcl_Obj *CONST *objv; /* Actual parameter vector */ { - Tcl_Obj* valuePtr; double dResult; +#if 0 + Tcl_Obj* valuePtr; Tcl_Obj* oResult; /* @@ -5231,6 +5313,68 @@ ExprDoubleFunc(clientData, interp, objc, objv) } return TCL_ERROR; +#else + if (objc != 2) { + MathFuncWrongNumArgs(interp, 2, objc, objv); + return TCL_ERROR; + } + if (Tcl_GetDoubleFromObj(interp, objv[1], &dResult) != TCL_OK) { +#ifdef ACCEPT_NAN + if (objv[1]->typePtr == &tclDoubleType) { + Tcl_SetObjResult(interp, objv[1]); + return TCL_OK; + } +#endif + return TCL_ERROR; + } + Tcl_SetObjResult(interp, Tcl_NewDoubleObj(dResult)); + return TCL_OK; +#endif +} + +static int +ExprEntierFunc(clientData, interp, objc, objv) + ClientData clientData; /* Ignored. */ + Tcl_Interp *interp; /* The interpreter in which to execute the + * function. */ + int objc; /* Actual parameter count */ + Tcl_Obj *CONST *objv; /* Actual parameter vector */ +{ + double d; + int type; + ClientData ptr; + + if (objc != 2) { + MathFuncWrongNumArgs(interp, 2, objc, objv); + return TCL_ERROR; + } + if (TclGetNumberFromObj(interp, objv[1], &ptr, &type) != TCL_OK) { + return TCL_ERROR; + } + if (type == TCL_NUMBER_DOUBLE) { + d = *((CONST double *)ptr); + if ((d >= (double)LONG_MAX) || (d <= (double)LONG_MIN)) { + mp_int big; + if (TclInitBignumFromDouble(interp, d, &big) != TCL_OK) { + /* Infinity */ + return TCL_ERROR; + } + Tcl_SetObjResult(interp, Tcl_NewBignumObj(&big)); + return TCL_OK; + } else { + long result = (long)d; + Tcl_SetObjResult(interp, Tcl_NewLongObj(result)); + return TCL_OK; + } + } + if (type != TCL_NUMBER_NAN) { + /* All integers are already of integer type */ + Tcl_SetObjResult(interp, objv[1]); + return TCL_OK; + } + /* Get the error message for NaN */ + Tcl_GetDoubleFromObj(interp, objv[1], &d); + return TCL_ERROR; } static int @@ -5241,9 +5385,10 @@ ExprIntFunc(clientData, interp, objc, objv) int objc; /* Actual parameter count */ Tcl_Obj *CONST *objv; /* Actual parameter vector */ { - register Tcl_Obj *valuePtr; long iResult; - double d; + Tcl_Obj *objPtr; +#if 0 + register Tcl_Obj *valuePtr; Tcl_Obj* oResult; if (objc != 2) { @@ -5282,6 +5427,24 @@ ExprIntFunc(clientData, interp, objc, objv) } } return TCL_ERROR; +#else + if (ExprEntierFunc(NULL, interp, objc, objv) != TCL_OK) { + return TCL_ERROR; + } + objPtr = Tcl_GetObjResult(interp); + if (Tcl_GetLongFromObj(NULL, objPtr, &iResult) != TCL_OK) { + /* truncate the bignum; keep only bits in long range */ + mp_int big; + Tcl_GetBignumFromObj(NULL, objPtr, &big); + mp_mod_2d(&big, (int) CHAR_BIT * sizeof(long), &big); + objPtr = Tcl_NewBignumObj(&big); + Tcl_IncrRefCount(objPtr); + Tcl_GetLongFromObj(NULL, objPtr, &iResult); + Tcl_DecrRefCount(objPtr); + } + Tcl_SetObjResult(interp, Tcl_NewLongObj(iResult)); + return TCL_OK; +#endif } static int @@ -5292,10 +5455,10 @@ ExprWideFunc(clientData, interp, objc, objv) int objc; /* Actual parameter count */ Tcl_Obj *CONST *objv; /* Actual parameter vector */ { - - register Tcl_Obj *valuePtr; Tcl_WideInt wResult; - double d; + Tcl_Obj *objPtr; +#if 0 + register Tcl_Obj *valuePtr; Tcl_Obj* oResult; if (objc != 2) { @@ -5334,6 +5497,24 @@ ExprWideFunc(clientData, interp, objc, objv) } } return TCL_ERROR; +#else + if (ExprEntierFunc(NULL, interp, objc, objv) != TCL_OK) { + return TCL_ERROR; + } + objPtr = Tcl_GetObjResult(interp); + if (Tcl_GetWideIntFromObj(NULL, objPtr, &wResult) != TCL_OK) { + /* truncate the bignum; keep only bits in wide int range */ + mp_int big; + Tcl_GetBignumFromObj(NULL, objPtr, &big); + mp_mod_2d(&big, (int) CHAR_BIT * sizeof(Tcl_WideInt), &big); + objPtr = Tcl_NewBignumObj(&big); + Tcl_IncrRefCount(objPtr); + Tcl_GetWideIntFromObj(NULL, objPtr, &wResult); + Tcl_DecrRefCount(objPtr); + } + Tcl_SetObjResult(interp, Tcl_NewWideIntObj(wResult)); + return TCL_OK; +#endif } static int @@ -5437,78 +5618,60 @@ ExprRoundFunc(clientData, interp, objc, objv) int objc; /* Actual parameter count */ Tcl_Obj *CONST *objv; /* Parameter vector */ { - Tcl_Obj *valuePtr, *resPtr; - double d, i, f; - - /* - * Check the argument count. - */ + double d; + ClientData ptr; + int type; if (objc != 2) { MathFuncWrongNumArgs(interp, 1, objc, objv); return TCL_ERROR; } - valuePtr = objv[1]; - /* - * Coerce the argument to a number. Integers are already rounded. - */ - - if (VerifyExprObjType(interp, valuePtr) != TCL_OK) { + if (TclGetNumberFromObj(interp, objv[1], &ptr, &type) != TCL_OK) { return TCL_ERROR; } - if ((valuePtr->typePtr == &tclIntType) || - (valuePtr->typePtr == &tclWideIntType)) { - Tcl_SetObjResult(interp, valuePtr); - return TCL_OK; - } - GET_DOUBLE_VALUE(d, valuePtr, valuePtr->typePtr); - - /* - * Round the number to the nearest integer. I'd like to use round(), but - * it's C99 (or BSD), and not yet universal. - */ + if (type == TCL_NUMBER_DOUBLE) { + double fractPart, intPart; + long max = LONG_MAX, min = LONG_MIN; - d = valuePtr->internalRep.doubleValue; - f = modf(d, &i); - if (d < 0.0) { - if (f <= -0.5) { - i += -1.0; + fractPart = modf(*((CONST double *)ptr), &intPart); + if (fractPart <= -0.5) { + min++; + } else if (fractPart >= 0.5) { + max--; } - if (i <= Tcl_WideAsDouble(LLONG_MIN)) { - goto tooLarge; - } else if (d <= (double) LONG_MIN) { - resPtr = Tcl_NewWideIntObj(Tcl_DoubleAsWide(i)); - } else { - resPtr = Tcl_NewLongObj((long) i); - } - } else { - if (f >= 0.5) { - i += 1.0; - } - if (i >= Tcl_WideAsDouble(LLONG_MAX)) { - goto tooLarge; - } else if (i >= (double) LONG_MAX) { - resPtr = Tcl_NewWideIntObj(Tcl_DoubleAsWide(i)); + if ((intPart >= (double)max) || (intPart <= (double)min)) { + mp_int big; + if (TclInitBignumFromDouble(interp, intPart, &big) != TCL_OK) { + /* Infinity */ + return TCL_ERROR; + } + if (fractPart <= -0.5) { + mp_sub_d(&big, 1, &big); + } else if (fractPart >= 0.5) { + mp_add_d(&big, 1, &big); + } + Tcl_SetObjResult(interp, Tcl_NewBignumObj(&big)); + return TCL_OK; } else { - resPtr = Tcl_NewLongObj((long) i); + long result = (long)intPart; + if (fractPart <= -0.5) { + result--; + } else if (fractPart >= 0.5) { + result++; + } + Tcl_SetObjResult(interp, Tcl_NewLongObj(result)); + return TCL_OK; } } - Tcl_SetObjResult(interp, resPtr); - return TCL_OK; - - /* - * Error return: result cannot be represented as an integer. - */ - - tooLarge: - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "integer value too large to represent", -1)); - Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", - "integer value too large to represent", (char *) NULL); - + if (type != TCL_NUMBER_NAN) { + /* All integers are already rounded */ + Tcl_SetObjResult(interp, objv[1]); + return TCL_OK; + } + /* Get the error message for NaN */ + Tcl_GetDoubleFromObj(interp, objv[1], &d); return TCL_ERROR; - } static int @@ -5520,7 +5683,6 @@ ExprSrandFunc(clientData, interp, objc, objv) Tcl_Obj *CONST *objv; /* Parameter vector */ { Interp *iPtr = (Interp *) interp; - Tcl_Obj *valuePtr; long i = 0; /* Initialized to avoid compiler warning. */ /* @@ -5531,18 +5693,9 @@ ExprSrandFunc(clientData, interp, objc, objv) MathFuncWrongNumArgs(interp, 2, objc, objv); return TCL_ERROR; } - valuePtr = objv[1]; - if (VerifyExprObjType(interp, valuePtr) != TCL_OK) { - return TCL_ERROR; - } - - if (Tcl_GetLongFromObj(NULL, valuePtr, &i) != TCL_OK) { - /* - * At this point, the only other possible type is double - */ - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "can't use floating-point value as argument to srand", -1)); + if (Tcl_GetLongFromObj(interp, objv[1], &i) != TCL_OK) { + /* TODO: more ::errorInfo here? or in caller? */ return TCL_ERROR; } @@ -5571,61 +5724,6 @@ ExprSrandFunc(clientData, interp, objc, objv) /* *---------------------------------------------------------------------- * - * VerifyExprObjType -- - * - * This procedure is called by the math functions to verify that the - * object is either an int or double, coercing it if necessary. If an - * error occurs during conversion, an error message is left in the - * interpreter's result unless "interp" is NULL. - * - * Results: - * TCL_OK if it was int or double, TCL_ERROR otherwise - * - * Side effects: - * objPtr is ensured to be of tclIntType, tclWideIntType or - * tclDoubleType. - * - *---------------------------------------------------------------------- - */ - -static int -VerifyExprObjType(interp, objPtr) - Tcl_Interp *interp; /* The interpreter in which to execute the - * function. */ - Tcl_Obj *objPtr; /* Points to the object to type check. */ -{ - if (IS_NUMERIC_TYPE(objPtr->typePtr)) { - return TCL_OK; - } else { - int length, result = TCL_OK; - char *s = Tcl_GetStringFromObj(objPtr, &length); - - if (TclLooksLikeInt(s, length)) { - long i; /* Set but never used, needed in GET_WIDE_OR_INT */ - Tcl_WideInt w; - GET_WIDE_OR_INT(result, objPtr, i, w); - } else { - double d; - result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL, objPtr, &d); - } - if ((result != TCL_OK) && (interp != NULL)) { - if (TclCheckBadOctal((Tcl_Interp *) NULL, s)) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "argument to math function was an invalid octal number", - -1)); - } else { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "argument to math function didn't have numeric value", - -1)); - } - } - return result; - } -} - -/* - *---------------------------------------------------------------------- - * * MathFuncWrongNumArgs -- * * Generate an error message when a math function presents the wrong diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index a5124c2..18e7f01 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -10,12 +10,14 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclCmdAH.c,v 1.68 2005/09/14 21:32:17 dgp Exp $ + * RCS: @(#) $Id: tclCmdAH.c,v 1.69 2005/10/08 14:42:44 dgp Exp $ */ #include "tclInt.h" #include <locale.h> +#define NEW_FORMAT 1 + /* * Prototypes for local procedures defined in this file: */ @@ -2245,6 +2247,7 @@ Tcl_FormatObjCmd(dummy, interp, objc, objv) case 'G': if (Tcl_GetDoubleFromObj(interp, /* INTL: Tcl source. */ objv[objIndex], &doubleValue) != TCL_OK) { + /*TODO: figure out ACCEPT_NAN */ goto fmtError; } whichValue = DOUBLE_VALUE; diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index b98cf56..c7a9d83 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -16,7 +16,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclCmdIL.c,v 1.81 2005/09/14 21:32:17 dgp Exp $ + * RCS: @(#) $Id: tclCmdIL.c,v 1.82 2005/10/08 14:42:44 dgp Exp $ */ #include "tclInt.h" @@ -301,16 +301,19 @@ Tcl_IncrObjCmd(dummy, interp, objc, objv) int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { +#if 0 long incrAmount = 1; Tcl_WideInt wideIncrAmount; - Tcl_Obj *newValuePtr; int isWide = 0; +#endif + Tcl_Obj *newValuePtr, *incrPtr; if ((objc != 2) && (objc != 3)) { Tcl_WrongNumArgs(interp, 1, objv, "varName ?increment?"); return TCL_ERROR; } +#if 0 /* * Calculate the amount to increment by. */ @@ -357,6 +360,18 @@ Tcl_IncrObjCmd(dummy, interp, objc, objv) newValuePtr = TclIncrVar2(interp, objv[1], (Tcl_Obj *) NULL, incrAmount, TCL_LEAVE_ERR_MSG); } +#else + if (objc == 3) { + incrPtr = objv[2]; + } else { + incrPtr = Tcl_NewIntObj(1); + } + Tcl_IncrRefCount(incrPtr); + newValuePtr = TclIncrObjVar2(interp, objv[1], NULL, + incrPtr, TCL_LEAVE_ERR_MSG); + Tcl_DecrRefCount(incrPtr); + +#endif if (newValuePtr == NULL) { return TCL_ERROR; } diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index b4a7d5a..a016124 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -15,7 +15,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclCmdMZ.c,v 1.131 2005/09/15 16:40:02 dgp Exp $ + * RCS: @(#) $Id: tclCmdMZ.c,v 1.132 2005/10/08 14:42:44 dgp Exp $ */ #include "tclInt.h" @@ -1530,52 +1530,20 @@ Tcl_StringObjCmd(dummy, interp, objc, objv) case STR_IS_DOUBLE: { char *stop; + /* TODO */ if ((objPtr->typePtr == &tclDoubleType) || - (objPtr->typePtr == &tclIntType)) { - break; - } - - /* - * This is adapted from Tcl_GetDouble - * - * The danger in this function is that "12345678901234567890" is - * an acceptable 'double', but will later be interp'd as an int by - * something like [expr]. Therefore, we check to see if it looks - * like an int, and if so we do a range check on it. If strtoul - * gets to the end, we know we either received an acceptable int, - * or over/underflow. - */ - - if (TclLooksLikeInt(string1, length1)) { - errno = 0; -#ifdef TCL_WIDE_INT_IS_LONG - strtoul(string1, &stop, 0); /* INTL: Tcl source. */ -#else - strtoull(string1, &stop, 0); /* INTL: Tcl source. */ + (objPtr->typePtr == &tclIntType) || +#ifndef NO_WIDE_TYPE + (objPtr->typePtr == &tclWideIntType) || #endif - if (stop == end) { - if (errno == ERANGE) { - result = 0; - failat = -1; - } - break; - } + (objPtr->typePtr == &tclBignumType)) { + break; } - errno = 0; - TclStrToD(string1, (CONST char **) &stop); /* INTL: Tcl source. */ - if (stop == string1) { - /* - * In this case, nothing like a number was found. - */ - + if (TclParseNumber( NULL, objPtr, NULL, NULL, -1, + (CONST char**) &stop, 0 ) != TCL_OK) { result = 0; failat = 0; } else { - /* - * Assume we sucked up one char per byte and then we go onto - * SPACE, since we are allowed trailing whitespace. - */ - failat = stop - string1; string1 = stop; chcomp = Tcl_UniCharIsSpace; diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 4f962ca..c340846 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -12,7 +12,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclCompCmds.c,v 1.77 2005/07/21 21:49:00 dkf Exp $ + * RCS: @(#) $Id: tclCompCmds.c,v 1.78 2005/10/08 14:42:45 dgp Exp $ */ #include "tclInt.h" @@ -611,6 +611,7 @@ TclCompileDictCmd(interp, parsePtr, envPtr) word = incrTokenPtr[1].start; numBytes = incrTokenPtr[1].size; +#if 0 /* * Note there is a danger that modifying the string could have * undesirable side effects. In this case, TclLooksLikeInt has no @@ -620,6 +621,7 @@ TclCompileDictCmd(interp, parsePtr, envPtr) if (!TclLooksLikeInt(word, numBytes)) { return TCL_ERROR; } +#endif /* * Now try to really parse the number. @@ -1959,7 +1961,7 @@ TclCompileIncrCmd(interp, parsePtr, envPtr) if (incrTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { CONST char *word = incrTokenPtr[1].start; int numBytes = incrTokenPtr[1].size; - +#if 0 /* * Note there is a danger that modifying the string could have * undesirable side effects. In this case, TclLooksLikeInt has @@ -1967,6 +1969,7 @@ TclCompileIncrCmd(interp, parsePtr, envPtr) */ if (TclLooksLikeInt(word, numBytes)) { +#endif int code; Tcl_Obj *intObj = Tcl_NewStringObj(word, numBytes); Tcl_IncrRefCount(intObj); @@ -1976,7 +1979,9 @@ TclCompileIncrCmd(interp, parsePtr, envPtr) && (-127 <= immValue) && (immValue <= 127)) { haveImmValue = 1; } +#if 0 } +#endif if (!haveImmValue) { PushLiteral(envPtr, word, numBytes); } @@ -2280,8 +2285,11 @@ TclCompileLindexCmd(interp, parsePtr, envPtr) varTokenPtr = TokenAfter(parsePtr->tokenPtr); - if ((numWords == 3) && (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) && - TclLooksLikeInt(varTokenPtr[1].start, varTokenPtr[1].size)) { + if ((numWords == 3) && (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) +#if 0 + && TclLooksLikeInt(varTokenPtr[1].start, varTokenPtr[1].size) +#endif + ) { Tcl_Obj *tmpObj; int idx, result; diff --git a/generic/tclCompExpr.c b/generic/tclCompExpr.c index e102d28..7741d1d 100644 --- a/generic/tclCompExpr.c +++ b/generic/tclCompExpr.c @@ -9,28 +9,13 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclCompExpr.c,v 1.28 2005/08/03 22:25:11 dgp Exp $ + * RCS: @(#) $Id: tclCompExpr.c,v 1.29 2005/10/08 14:42:45 dgp Exp $ */ #include "tclInt.h" #include "tclCompile.h" /* - * The stuff below is a bit of a hack so that this file can be used in - * environments that include no UNIX, i.e. no errno: just arrange to use the - * errno from tclExecute.c here. - */ - -#ifdef TCL_GENERIC_ONLY -#define NO_ERRNO_H -#endif - -#ifdef NO_ERRNO_H -extern int errno; /* Use errno from tclExecute.c. */ -#define ERANGE 34 -#endif - -/* * Boolean variable that controls whether expression compilation tracing is * enabled. */ diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 4528521..f01f3ca 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -8,7 +8,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclDecls.h,v 1.116 2005/09/13 21:23:51 dgp Exp $ + * RCS: @(#) $Id: tclDecls.h,v 1.117 2005/10/08 14:42:45 dgp Exp $ */ #ifndef _TCLDECLS @@ -3484,39 +3484,46 @@ EXTERN void Tcl_SetBignumObj _ANSI_ARGS_((Tcl_Obj* obj, EXTERN int Tcl_GetBignumFromObj _ANSI_ARGS_((Tcl_Interp* interp, Tcl_Obj* obj, mp_int* value)); #endif +#ifndef Tcl_GetBignumAndClearObj_TCL_DECLARED +#define Tcl_GetBignumAndClearObj_TCL_DECLARED +/* 559 */ +EXTERN int Tcl_GetBignumAndClearObj _ANSI_ARGS_(( + Tcl_Interp* interp, Tcl_Obj* obj, + mp_int* value)); +#endif #ifndef Tcl_TruncateChannel_TCL_DECLARED #define Tcl_TruncateChannel_TCL_DECLARED -/* 559 */ +/* 560 */ EXTERN int Tcl_TruncateChannel _ANSI_ARGS_((Tcl_Channel chan, Tcl_WideInt length)); #endif #ifndef Tcl_ChannelTruncateProc_TCL_DECLARED #define Tcl_ChannelTruncateProc_TCL_DECLARED -/* 560 */ +/* 561 */ EXTERN Tcl_DriverTruncateProc * Tcl_ChannelTruncateProc _ANSI_ARGS_(( Tcl_ChannelType * chanTypePtr)); #endif #ifndef Tcl_SetChannelErrorInterp_TCL_DECLARED #define Tcl_SetChannelErrorInterp_TCL_DECLARED -/* 561 */ +/* 562 */ EXTERN void Tcl_SetChannelErrorInterp _ANSI_ARGS_(( Tcl_Interp* interp, Tcl_Obj* msg)); #endif #ifndef Tcl_GetChannelErrorInterp_TCL_DECLARED #define Tcl_GetChannelErrorInterp_TCL_DECLARED -/* 562 */ +/* 563 */ EXTERN void Tcl_GetChannelErrorInterp _ANSI_ARGS_(( Tcl_Interp* interp, Tcl_Obj** msg)); #endif #ifndef Tcl_SetChannelError_TCL_DECLARED #define Tcl_SetChannelError_TCL_DECLARED -/* 563 */ +/* 564 */ EXTERN void Tcl_SetChannelError _ANSI_ARGS_((Tcl_Channel chan, Tcl_Obj* msg)); #endif #ifndef Tcl_GetChannelError_TCL_DECLARED #define Tcl_GetChannelError_TCL_DECLARED -/* 564 */ +/* 565 */ EXTERN void Tcl_GetChannelError _ANSI_ARGS_((Tcl_Channel chan, Tcl_Obj** msg)); #endif @@ -4120,12 +4127,13 @@ typedef struct TclStubs { Tcl_Obj* (*tcl_DbNewBignumObj) _ANSI_ARGS_((mp_int* value, CONST char* file, int line)); /* 556 */ void (*tcl_SetBignumObj) _ANSI_ARGS_((Tcl_Obj* obj, mp_int* value)); /* 557 */ int (*tcl_GetBignumFromObj) _ANSI_ARGS_((Tcl_Interp* interp, Tcl_Obj* obj, mp_int* value)); /* 558 */ - int (*tcl_TruncateChannel) _ANSI_ARGS_((Tcl_Channel chan, Tcl_WideInt length)); /* 559 */ - Tcl_DriverTruncateProc * (*tcl_ChannelTruncateProc) _ANSI_ARGS_((Tcl_ChannelType * chanTypePtr)); /* 560 */ - void (*tcl_SetChannelErrorInterp) _ANSI_ARGS_((Tcl_Interp* interp, Tcl_Obj* msg)); /* 561 */ - void (*tcl_GetChannelErrorInterp) _ANSI_ARGS_((Tcl_Interp* interp, Tcl_Obj** msg)); /* 562 */ - void (*tcl_SetChannelError) _ANSI_ARGS_((Tcl_Channel chan, Tcl_Obj* msg)); /* 563 */ - void (*tcl_GetChannelError) _ANSI_ARGS_((Tcl_Channel chan, Tcl_Obj** msg)); /* 564 */ + int (*tcl_GetBignumAndClearObj) _ANSI_ARGS_((Tcl_Interp* interp, Tcl_Obj* obj, mp_int* value)); /* 559 */ + int (*tcl_TruncateChannel) _ANSI_ARGS_((Tcl_Channel chan, Tcl_WideInt length)); /* 560 */ + Tcl_DriverTruncateProc * (*tcl_ChannelTruncateProc) _ANSI_ARGS_((Tcl_ChannelType * chanTypePtr)); /* 561 */ + void (*tcl_SetChannelErrorInterp) _ANSI_ARGS_((Tcl_Interp* interp, Tcl_Obj* msg)); /* 562 */ + void (*tcl_GetChannelErrorInterp) _ANSI_ARGS_((Tcl_Interp* interp, Tcl_Obj** msg)); /* 563 */ + void (*tcl_SetChannelError) _ANSI_ARGS_((Tcl_Channel chan, Tcl_Obj* msg)); /* 564 */ + void (*tcl_GetChannelError) _ANSI_ARGS_((Tcl_Channel chan, Tcl_Obj** msg)); /* 565 */ } TclStubs; #ifdef __cplusplus @@ -6402,29 +6410,33 @@ extern TclStubs *tclStubsPtr; #define Tcl_GetBignumFromObj \ (tclStubsPtr->tcl_GetBignumFromObj) /* 558 */ #endif +#ifndef Tcl_GetBignumAndClearObj +#define Tcl_GetBignumAndClearObj \ + (tclStubsPtr->tcl_GetBignumAndClearObj) /* 559 */ +#endif #ifndef Tcl_TruncateChannel #define Tcl_TruncateChannel \ - (tclStubsPtr->tcl_TruncateChannel) /* 559 */ + (tclStubsPtr->tcl_TruncateChannel) /* 560 */ #endif #ifndef Tcl_ChannelTruncateProc #define Tcl_ChannelTruncateProc \ - (tclStubsPtr->tcl_ChannelTruncateProc) /* 560 */ + (tclStubsPtr->tcl_ChannelTruncateProc) /* 561 */ #endif #ifndef Tcl_SetChannelErrorInterp #define Tcl_SetChannelErrorInterp \ - (tclStubsPtr->tcl_SetChannelErrorInterp) /* 561 */ + (tclStubsPtr->tcl_SetChannelErrorInterp) /* 562 */ #endif #ifndef Tcl_GetChannelErrorInterp #define Tcl_GetChannelErrorInterp \ - (tclStubsPtr->tcl_GetChannelErrorInterp) /* 562 */ + (tclStubsPtr->tcl_GetChannelErrorInterp) /* 563 */ #endif #ifndef Tcl_SetChannelError #define Tcl_SetChannelError \ - (tclStubsPtr->tcl_SetChannelError) /* 563 */ + (tclStubsPtr->tcl_SetChannelError) /* 564 */ #endif #ifndef Tcl_GetChannelError #define Tcl_GetChannelError \ - (tclStubsPtr->tcl_GetChannelError) /* 564 */ + (tclStubsPtr->tcl_GetChannelError) /* 565 */ #endif #endif /* defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) */ diff --git a/generic/tclDictObj.c b/generic/tclDictObj.c index 196455e..aa88d69 100644 --- a/generic/tclDictObj.c +++ b/generic/tclDictObj.c @@ -9,10 +9,11 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclDictObj.c,v 1.35 2005/09/16 01:40:15 dgp Exp $ + * RCS: @(#) $Id: tclDictObj.c,v 1.36 2005/10/08 14:42:45 dgp Exp $ */ #include "tclInt.h" +#include "tommath.h" /* * Forward declaration. @@ -1873,17 +1874,23 @@ DictIncrCmd(interp, objc, objv) int objc; Tcl_Obj *CONST *objv; { - Tcl_Obj *dictPtr, *valuePtr, *resultPtr; +#if 0 + Tcl_Obj *dictPtr, *resultPtr; int result, isWide = 0; long incrValue = 1; Tcl_WideInt wideIncrValue = 0; int allocatedDict = 0; +#else + int code = TCL_OK; + Tcl_Obj *dictPtr, *valuePtr = NULL; +#endif if (objc < 4 || objc > 5) { Tcl_WrongNumArgs(interp, 2, objv, "varName key ?increment?"); return TCL_ERROR; } +#if 0 if (objc == 5) { if (objv[4]->typePtr == &tclIntType) { incrValue = objv[4]->internalRep.longValue; @@ -2040,6 +2047,67 @@ DictIncrCmd(interp, objc, objv) } Tcl_SetObjResult(interp, resultPtr); return TCL_OK; +#else + dictPtr = Tcl_ObjGetVar2(interp, objv[2], NULL, 0); + if (dictPtr == NULL) { + /* Variable didn't yet exist. Create new dictionary value */ + dictPtr = Tcl_NewDictObj(); + } else if (Tcl_DictObjGet(interp, dictPtr, objv[3], &valuePtr) != TCL_OK) { + /* Variable contents are not a dict, report error */ + return TCL_ERROR; + } + if (Tcl_IsShared(dictPtr)) { + /* A little internals surgery to avoid copying a string rep + * that will soon be no good */ + char *saved = dictPtr->bytes; + dictPtr->bytes = NULL; + dictPtr = Tcl_DuplicateObj(dictPtr); + dictPtr->bytes = saved; + } + if (valuePtr == NULL) { + /* Key not in dictionary. Create new key with increment as value */ + if (objc == 5) { + /* Verify increment is an integer */ + mp_int increment; + code = Tcl_GetBignumFromObj(interp, objv[4], &increment); + if (code != TCL_OK) { + Tcl_AddErrorInfo(interp, "\n (reading increment)"); + } else { + Tcl_DictObjPut(interp, dictPtr, objv[3], objv[4]); + } + } else { + Tcl_DictObjPut(interp, dictPtr, objv[3], Tcl_NewIntObj(1)); + } + } else { + /* Key in dictionary. Increment its value with minimum dup. */ + if (Tcl_IsShared(valuePtr)) { + valuePtr = Tcl_DuplicateObj(valuePtr); + Tcl_DictObjPut(interp, dictPtr, objv[3], valuePtr); + } + if (objc == 5) { + code = TclIncrObj(interp, valuePtr, objv[4]); + } else { + Tcl_Obj *incrPtr = Tcl_NewIntObj(1); + Tcl_IncrRefCount(incrPtr); + code = TclIncrObj(interp, valuePtr, incrPtr); + Tcl_DecrRefCount(incrPtr); + } + } + Tcl_IncrRefCount(dictPtr); + if (code == TCL_OK) { + Tcl_InvalidateStringRep(dictPtr); + valuePtr = Tcl_ObjSetVar2(interp, objv[2], NULL, + dictPtr, TCL_LEAVE_ERR_MSG); + if (valuePtr == NULL) { + code = TCL_ERROR; + } + } + Tcl_DecrRefCount(dictPtr); + if (code == TCL_OK) { + Tcl_SetObjResult(interp, valuePtr); + } + return code; +#endif } /* diff --git a/generic/tclExecute.c b/generic/tclExecute.c index c7502f0..33e5ae2 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -12,11 +12,12 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclExecute.c,v 1.201 2005/09/15 16:40:02 dgp Exp $ + * RCS: @(#) $Id: tclExecute.c,v 1.202 2005/10/08 14:42:45 dgp Exp $ */ #include "tclInt.h" #include "tclCompile.h" +#include "tommath.h" #include <math.h> #include <float.h> @@ -48,26 +49,13 @@ # define NO_ERRNO_H #endif /* !TCL_GENERIC_ONLY */ +#if 0 #ifdef NO_ERRNO_H int errno; # define EDOM 33 # define ERANGE 34 #endif - -/* - * Need DBL_MAX for IS_INF() macro... - */ -#ifndef DBL_MAX -# ifdef MAXDOUBLE -# define DBL_MAX MAXDOUBLE -# else /* !MAXDOUBLE */ -/* - * This value is from the Solaris headers, but doubles seem to be the same - * size everywhere. Long doubles aren't, but we don't use those. - */ -# define DBL_MAX 1.79769313486231570e+308 -# endif /* MAXDOUBLE */ -#endif /* !DBL_MAX */ +#endif /* * A mask (should be 2**n-1) that is used to work out when the bytecode engine @@ -141,20 +129,6 @@ long tclObjsShared[TCL_MAX_SHARED_OBJ_STATS] = { 0, 0, 0, 0, 0 }; #endif /* TCL_COMPILE_STATS */ /* - * Macros for testing floating-point values for certain special cases. Test - * for not-a-number by comparing a value against itself; test for infinity by - * comparing against the largest floating-point value. - */ - -#ifdef _MSC_VER -#define IS_NAN(f) (_isnan((f))) -#define IS_INF(f) ( ! (_finite((f)))) -#else -#define IS_NAN(f) ((f) != (f)) -#define IS_INF(f) ( (f) > DBL_MAX || (f) < -DBL_MAX ) -#endif - -/* * The new macro for ending an instruction; note that a reasonable C-optimiser * will resolve all branches at compile time. (result) is always a constant; * the macro NEXT_INST_F handles constant (nCleanup), NEXT_INST_V is resolved @@ -286,6 +260,7 @@ long tclObjsShared[TCL_MAX_SHARED_OBJ_STATS] = { 0, 0, 0, 0, 0 }; # define O2S(objPtr) #endif /* TCL_COMPILE_DEBUG */ +#if 0 /* * Macro to read a string containing either a wide or an int and decide which * it is while decoding it at the same time. This enforces the policy that @@ -295,6 +270,7 @@ long tclObjsShared[TCL_MAX_SHARED_OBJ_STATS] = { 0, 0, 0, 0, 0 }; * * GET_WIDE_OR_INT is the same as REQUIRE_WIDE_OR_INT except it never * generates an error message. + * */ #define REQUIRE_WIDE_OR_INT(resultVar, objPtr, longVar, wideVar) \ (resultVar) = Tcl_GetWideIntFromObj(interp, (objPtr), &(wideVar)); \ @@ -313,15 +289,17 @@ long tclObjsShared[TCL_MAX_SHARED_OBJ_STATS] = { 0, 0, 0, 0, 0 }; (objPtr)->internalRep.longValue = (longVar) \ = Tcl_WideAsLong(wideVar); \ } +#endif /* * Combined with REQUIRE_WIDE_OR_INT, this gets a long value from an obj. */ +#if 0 #define FORCE_LONG(objPtr, longVar, wideVar) \ if ((objPtr)->typePtr == &tclWideIntType) { \ (longVar) = Tcl_WideAsLong(wideVar); \ } #define IS_INTEGER_TYPE(typePtr) \ - ((typePtr) == &tclIntType || (typePtr) == &tclWideIntType) + ((typePtr) == &tclIntType || (typePtr) == &tclWideIntType || (typePtr) == &tclBignumType) #define IS_NUMERIC_TYPE(typePtr) \ (IS_INTEGER_TYPE(typePtr) || (typePtr) == &tclDoubleType) @@ -351,6 +329,89 @@ long tclObjsShared[TCL_MAX_SHARED_OBJ_STATS] = { 0, 0, 0, 0, 0 }; (doubleVar) = (objPtr)->internalRep.doubleValue; \ } #endif /* TCL_WIDE_INT_IS_LONG */ +#endif + +/* + * Macro used in this file to save a function call for common uses of + * TclGetNumberFromObj(). The ANSI C "prototype" is: + * + * MODULE_SCOPE int GetNumberFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, + * ClientData *ptrPtr, int *tPtr); + */ + +#ifdef TCL_WIDE_INT_IS_LONG + +#define GetNumberFromObj(interp, objPtr, ptrPtr, tPtr) \ + (((objPtr)->typePtr == &tclIntType) \ + ? (*(tPtr) = TCL_NUMBER_LONG, \ + *(ptrPtr) = (ClientData) \ + (&((objPtr)->internalRep.longValue)), TCL_OK) : \ + ((objPtr)->typePtr == &tclDoubleType) \ + ? (((TclIsNaN((objPtr)->internalRep.doubleValue)) \ + ? (*(tPtr) = TCL_NUMBER_NAN) \ + : (*(tPtr) = TCL_NUMBER_DOUBLE)), \ + *(ptrPtr) = (ClientData) \ + (&((objPtr)->internalRep.doubleValue)), TCL_OK) : \ + TclGetNumberFromObj((interp), (objPtr), (ptrPtr), (tPtr))) + +#else + +#define GetNumberFromObj(interp, objPtr, ptrPtr, tPtr) \ + (((objPtr)->typePtr == &tclIntType) \ + ? (*(tPtr) = TCL_NUMBER_LONG, \ + *(ptrPtr) = (ClientData) \ + (&((objPtr)->internalRep.longValue)), TCL_OK) : \ + ((objPtr)->typePtr == &tclWideIntType) \ + ? (*(tPtr) = TCL_NUMBER_WIDE, \ + *(ptrPtr) = (ClientData) \ + (&((objPtr)->internalRep.wideValue)), TCL_OK) : \ + ((objPtr)->typePtr == &tclDoubleType) \ + ? (((TclIsNaN((objPtr)->internalRep.doubleValue)) \ + ? (*(tPtr) = TCL_NUMBER_NAN) \ + : (*(tPtr) = TCL_NUMBER_DOUBLE)), \ + *(ptrPtr) = (ClientData) \ + (&((objPtr)->internalRep.doubleValue)), TCL_OK) : \ + TclGetNumberFromObj((interp), (objPtr), (ptrPtr), (tPtr))) + +#endif + +/* + * Macro used in this file to save a function call for common uses of + * Tcl_GetBooleanFromObj(). The ANSI C "prototype" is: + * + * MODULE_SCOPE int TclGetBooleanFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, + * int *boolPtr); + */ + +#define TclGetBooleanFromObj(interp, objPtr, boolPtr) \ + ((((objPtr)->typePtr == &tclIntType) \ + || ((objPtr)->typePtr == &tclIntType)) \ + ? (*(boolPtr) = ((objPtr)->internalRep.longValue!=0), TCL_OK) \ + : Tcl_GetBooleanFromObj((interp), (objPtr), (boolPtr))) + +/* + * Macro used in this file to save a function call for common uses of + * Tcl_GetWideIntFromObj(). The ANSI C "prototype" is: + * + * MODULE_SCOPE int TclGetWideIntFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, + * Tcl_WideInt *wideIntPtr); + */ + +#ifdef TCL_WIDE_INT_IS_LONG +#define TclGetWideIntFromObj(interp, objPtr, wideIntPtr) \ + (((objPtr)->typePtr == &tclIntType) \ + ? (*(wideIntPtr) = (Tcl_WideInt) \ + ((objPtr)->internalRep.longValue), TCL_OK) : \ + Tcl_GetWideIntFromObj((interp), (objPtr), (wideIntPtr))) +#else +#define TclGetWideIntFromObj(interp, objPtr, wideIntPtr) \ + (((objPtr)->typePtr == &tclWideIntType) \ + ? (*(wideIntPtr) = (objPtr)->internalRep.wideValue, TCL_OK) : \ + ((objPtr)->typePtr == &tclIntType) \ + ? (*(wideIntPtr) = (Tcl_WideInt) \ + ((objPtr)->internalRep.longValue), TCL_OK) : \ + Tcl_GetWideIntFromObj((interp), (objPtr), (wideIntPtr))) +#endif static Tcl_ObjType dictIteratorType = { "dictIterator", @@ -389,10 +450,12 @@ static void ValidatePcAndStackTop _ANSI_ARGS_(( int stackTop, int stackLowerBound, int checkStack)); #endif /* TCL_COMPILE_DEBUG */ +#if 0 static Tcl_WideInt ExponWide _ANSI_ARGS_((Tcl_WideInt w, Tcl_WideInt w2, int *errExpon)); static long ExponLong _ANSI_ARGS_((long i, long i2, int *errExpon)); +#endif /* @@ -481,9 +544,9 @@ TclCreateExecEnv(interp) eePtr->tosPtr = stackPtr - 1; eePtr->endPtr = stackPtr + (TCL_STACK_INITIAL_SIZE - 2); - TclNewIntObj(eePtr->constants[0], 0); + TclNewBooleanObj(eePtr->constants[0], 0); Tcl_IncrRefCount(eePtr->constants[0]); - TclNewIntObj(eePtr->constants[1], 1); + TclNewBooleanObj(eePtr->constants[1], 1); Tcl_IncrRefCount(eePtr->constants[1]); Tcl_MutexLock(&execMutex); @@ -753,24 +816,24 @@ Tcl_ExprObj(interp, objPtr, resultPtrPtr) string = Tcl_GetStringFromObj(objPtr, &length); if (length == 1) { if (*string == '0') { - TclNewLongObj(resultPtr, 0); + TclNewBooleanObj(resultPtr, 0); Tcl_IncrRefCount(resultPtr); *resultPtrPtr = resultPtr; return TCL_OK; } else if (*string == '1') { - TclNewLongObj(resultPtr, 1); + TclNewBooleanObj(resultPtr, 1); Tcl_IncrRefCount(resultPtr); *resultPtrPtr = resultPtr; return TCL_OK; } } else if ((length == 2) && (*string == '!')) { if (*(string+1) == '0') { - TclNewLongObj(resultPtr, 1); + TclNewBooleanObj(resultPtr, 1); Tcl_IncrRefCount(resultPtr); *resultPtrPtr = resultPtr; return TCL_OK; } else if (*(string+1) == '1') { - TclNewLongObj(resultPtr, 0); + TclNewBooleanObj(resultPtr, 0); Tcl_IncrRefCount(resultPtr); *resultPtrPtr = resultPtr; return TCL_OK; @@ -1031,6 +1094,79 @@ TclCompEvalObj(interp, objPtr) /* *---------------------------------------------------------------------- * + * TclIncrObj -- + * + * Increment an integeral value in a Tcl_Obj by an integeral value + * held in another Tcl_Obj. Caller is responsible for making sure + * we can update the first object. + * + * Results: + * TCL_ERROR if either object is non-integer, and TCL_OK otherwise. On + * error, an error message is left in the interpreter (if it is not NULL, + * of course). + * + * Side effects: + * valuePtr gets the new incrmented value. + * + *---------------------------------------------------------------------- + */ + +int +TclIncrObj(interp, valuePtr, incrPtr) + Tcl_Interp *interp; + Tcl_Obj *valuePtr; + Tcl_Obj *incrPtr; +{ + ClientData ptr1, ptr2; + int type1, type2; + mp_int value, incr; + + if (Tcl_IsShared(valuePtr)) { + Tcl_Panic("shared object passed to TclIncrObj"); + } + + if ((GetNumberFromObj(NULL, valuePtr, &ptr1, &type1) != TCL_OK) + || (type1 == TCL_NUMBER_DOUBLE) || (type1 == TCL_NUMBER_NAN)) { + /* Produce error message (reparse?!) */ + return Tcl_GetIntFromObj(interp, valuePtr, &type1); + } + if ((GetNumberFromObj(NULL, incrPtr, &ptr2, &type2) != TCL_OK) + || (type1 == TCL_NUMBER_DOUBLE) || (type1 == TCL_NUMBER_NAN)) { + /* Produce error message (reparse?!) */ + Tcl_GetIntFromObj(interp, incrPtr, &type1); + Tcl_AddErrorInfo(interp, "\n (reading increment)"); + return TCL_ERROR; + } + do {if ((type1 != TCL_NUMBER_BIG) && (type2 != TCL_NUMBER_BIG)) { + Tcl_WideInt w1, w2, sum; + TclGetWideIntFromObj(NULL, valuePtr, &w1); + TclGetWideIntFromObj(NULL, incrPtr, &w2); + sum = w1 + w2; +#ifndef NO_WIDE_TYPE + if ((type1 == TCL_NUMBER_WIDE) || (type2 == TCL_NUMBER_WIDE)) +#endif + { + /* Check for overflow */ + if (((w1 < 0) && (w2 < 0) && (sum > 0)) + || ((w1 > 0) && (w2 > 0) && (sum < 0))) { + break; + } + } + Tcl_SetWideIntObj(valuePtr, sum); + return TCL_OK; + }} while (0); + + Tcl_GetBignumAndClearObj(interp, valuePtr, &value); + Tcl_GetBignumFromObj(interp, incrPtr, &incr); + mp_add(&value, &incr, &value); + mp_clear(&incr); + Tcl_SetBignumObj(valuePtr, &value); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * * TclExecuteByteCode -- * * This procedure executes the instructions of a ByteCode structure. It @@ -2215,11 +2351,16 @@ TclExecuteByteCode(interp, codePtr) * common execution code. */ +/*TODO: Consider more untangling here; merge with LOAD and STORE ? */ + { - Tcl_Obj *objPtr; - int opnd, pcAdjustment, isWide; - long i; + Tcl_Obj *objPtr, *incrPtr; + int opnd, pcAdjustment; +#if 0 + int isWide; Tcl_WideInt w; +#endif + long i; char *part1, *part2; Var *varPtr, *arrayPtr; @@ -2229,6 +2370,7 @@ TclExecuteByteCode(interp, codePtr) case INST_INCR_SCALAR_STK: case INST_INCR_STK: opnd = TclGetUInt1AtPtr(pc+1); +#if 0 objPtr = *tosPtr; if (objPtr->typePtr == &tclIntType) { i = objPtr->internalRep.longValue; @@ -2250,6 +2392,10 @@ TclExecuteByteCode(interp, codePtr) } tosPtr--; TclDecrRefCount(objPtr); +#else + incrPtr = *tosPtr; + tosPtr--; +#endif switch (*pc) { case INST_INCR_SCALAR1: pcAdjustment = 2; @@ -2266,7 +2412,12 @@ TclExecuteByteCode(interp, codePtr) case INST_INCR_SCALAR_STK_IMM: case INST_INCR_STK_IMM: i = TclGetInt1AtPtr(pc+1); +#if 0 isWide = 0; +#else + incrPtr = Tcl_NewIntObj(i); + Tcl_IncrRefCount(incrPtr); +#endif pcAdjustment = 2; doIncrStk: @@ -2290,6 +2441,7 @@ TclExecuteByteCode(interp, codePtr) "\n (reading value of variable to increment)", -1); TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); result = TCL_ERROR; + Tcl_DecrRefCount(incrPtr); goto checkForCatch; } cleanup = ((part2 == NULL)? 1 : 2); @@ -2298,7 +2450,12 @@ TclExecuteByteCode(interp, codePtr) case INST_INCR_ARRAY1_IMM: opnd = TclGetUInt1AtPtr(pc+1); i = TclGetInt1AtPtr(pc+2); +#if 0 isWide = 0; +#else + incrPtr = Tcl_NewIntObj(i); + Tcl_IncrRefCount(incrPtr); +#endif pcAdjustment = 3; doIncrArray: @@ -2314,6 +2471,7 @@ TclExecuteByteCode(interp, codePtr) if (varPtr == NULL) { TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); result = TCL_ERROR; + Tcl_DecrRefCount(incrPtr); goto checkForCatch; } cleanup = 1; @@ -2322,7 +2480,12 @@ TclExecuteByteCode(interp, codePtr) case INST_INCR_SCALAR1_IMM: opnd = TclGetUInt1AtPtr(pc+1); i = TclGetInt1AtPtr(pc+2); +#if 0 isWide = 0; +#else + incrPtr = Tcl_NewIntObj(i); + Tcl_IncrRefCount(incrPtr); +#endif pcAdjustment = 3; doIncrScalar: @@ -2337,6 +2500,7 @@ TclExecuteByteCode(interp, codePtr) TRACE(("%u %ld => ", opnd, i)); doIncrVar: +#if 0 objPtr = varPtr->value.objPtr; if (TclIsVarDirectReadable(varPtr) && ((arrayPtr == NULL) || TclIsVarUntraced(arrayPtr))) { @@ -2385,12 +2549,22 @@ TclExecuteByteCode(interp, codePtr) part2, i, TCL_LEAVE_ERR_MSG); } CACHE_STACK_INFO(); +#else + /* TODO: Restore no trace optimization */ + DECACHE_STACK_INFO(); + objResultPtr = TclPtrIncrObjVar(interp, varPtr, arrayPtr, part1, part2, + incrPtr, TCL_LEAVE_ERR_MSG); + CACHE_STACK_INFO(); + Tcl_DecrRefCount(incrPtr); +#endif if (objResultPtr == NULL) { TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); result = TCL_ERROR; goto checkForCatch; } +#if 0 doneIncr: +#endif TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); #ifndef TCL_COMPILE_DEBUG if (*(pc+pcAdjustment) == INST_POP) { @@ -2430,6 +2604,8 @@ TclExecuteByteCode(interp, codePtr) int b; Tcl_Obj *valuePtr; +/* TODO: consider rewrite so we don't compute the offset we're + * not going to take. */ case INST_JUMP_FALSE4: jmpOffset[0] = TclGetInt4AtPtr(pc+1); /* FALSE offset */ jmpOffset[1] = 5; /* TRUE offset*/ @@ -2452,35 +2628,17 @@ TclExecuteByteCode(interp, codePtr) doCondJump: valuePtr = *tosPtr; - if (valuePtr->typePtr == &tclIntType) { - b = (valuePtr->internalRep.longValue != 0); - } else if (valuePtr->typePtr == &tclDoubleType) { - b = (valuePtr->internalRep.doubleValue != 0.0); - } else if (valuePtr->typePtr == &tclWideIntType) { - Tcl_WideInt w; - - TclGetWide(w,valuePtr); - b = (w != W0); - } else { - /* - * Taking b's address impedes it being a register variable (in gcc - * at least), so we avoid doing it. - */ - int b1; - result = Tcl_GetBooleanFromObj(interp, valuePtr, &b1); - if (result != TCL_OK) { - if ((*pc == INST_JUMP_FALSE1) || (*pc == INST_JUMP_FALSE4)) { - jmpOffset[1] = jmpOffset[0]; - } - TRACE_WITH_OBJ(("%d => ERROR: ", jmpOffset[1]), - Tcl_GetObjResult(interp)); - goto checkForCatch; - } - b = b1; + /* TODO - check claim that taking address of b harms performance */ + /* TODO - consider optimization search for eePtr->constants */ + result = TclGetBooleanFromObj(interp, valuePtr, &b); + if (result != TCL_OK) { + TRACE_WITH_OBJ(("%d => ERROR: ", jmpOffset[ + ((*pc == INST_JUMP_FALSE1) || (*pc == INST_JUMP_FALSE4)) + ? 0 : 1]), Tcl_GetObjResult(interp)); + goto checkForCatch; } -#ifndef TCL_COMPILE_DEBUG - NEXT_INST_F(jmpOffset[b], 1, 0); -#else + +#ifdef TCL_COMPILE_DEBUG if (b) { if ((*pc == INST_JUMP_TRUE1) || (*pc == INST_JUMP_TRUE4)) { TRACE(("%d => %.20s true, new pc %u\n", jmpOffset[1], O2S(valuePtr), @@ -2488,7 +2646,6 @@ TclExecuteByteCode(interp, codePtr) } else { TRACE(("%d => %.20s true\n", jmpOffset[0], O2S(valuePtr))); } - NEXT_INST_F(jmpOffset[1], 1, 0); } else { if ((*pc == INST_JUMP_TRUE1) || (*pc == INST_JUMP_TRUE4)) { TRACE(("%d => %.20s false\n", jmpOffset[0], O2S(valuePtr))); @@ -2496,9 +2653,9 @@ TclExecuteByteCode(interp, codePtr) TRACE(("%d => %.20s false, new pc %u\n", jmpOffset[0], O2S(valuePtr), (unsigned int)(pc + jmpOffset[1] - codePtr->codeStart))); } - NEXT_INST_F(jmpOffset[0], 1, 0); } #endif + NEXT_INST_F(jmpOffset[b], 1, 0); } /* @@ -2514,94 +2671,34 @@ TclExecuteByteCode(interp, codePtr) * performed. */ - int i1, i2, length; - int iResult; - char *s; - Tcl_ObjType *t1Ptr, *t2Ptr; - Tcl_Obj *valuePtr, *value2Ptr; - Tcl_WideInt w; - - value2Ptr = *tosPtr; - valuePtr = *(tosPtr - 1); - t1Ptr = valuePtr->typePtr; - t2Ptr = value2Ptr->typePtr; - - if (t1Ptr == &tclIntType) { - i1 = (valuePtr->internalRep.longValue != 0); - } else if (t1Ptr == &tclWideIntType) { - TclGetWide(w,valuePtr); - i1 = (w != W0); - } else if (t1Ptr == &tclDoubleType) { - i1 = (valuePtr->internalRep.doubleValue != 0.0); - } else { - s = Tcl_GetStringFromObj(valuePtr, &length); - if (TclLooksLikeInt(s, length)) { - long i = 0; + int i1, i2, iResult; + Tcl_Obj *value2Ptr = *tosPtr; + Tcl_Obj *valuePtr = *(tosPtr - 1); - GET_WIDE_OR_INT(result, valuePtr, i, w); - if (valuePtr->typePtr == &tclIntType) { - i1 = (i != 0); - } else { - i1 = (w != W0); - } - } else { - result = Tcl_GetBooleanFromObj(NULL, valuePtr, &i1); - } - if (result != TCL_OK) { - TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(valuePtr), - (t1Ptr? t1Ptr->name : "null"))); - IllegalExprOperandType(interp, pc, valuePtr); - goto checkForCatch; - } + result = TclGetBooleanFromObj(NULL, valuePtr, &i1); + if (result != TCL_OK) { + TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(valuePtr), + (valuePtr->typePtr? valuePtr->typePtr->name : "null"))); + IllegalExprOperandType(interp, pc, valuePtr); + goto checkForCatch; } - if (t2Ptr == &tclIntType) { - i2 = (value2Ptr->internalRep.longValue != 0); - } else if (t2Ptr == &tclWideIntType) { - TclGetWide(w,value2Ptr); - i2 = (w != W0); - } else if (t2Ptr == &tclDoubleType) { - i2 = (value2Ptr->internalRep.doubleValue != 0.0); - } else { - s = Tcl_GetStringFromObj(value2Ptr, &length); - if (TclLooksLikeInt(s, length)) { - long i = 0; - - GET_WIDE_OR_INT(result, value2Ptr, i, w); - if (value2Ptr->typePtr == &tclIntType) { - i2 = (i != 0); - } else { - i2 = (w != W0); - } - } else { - result = Tcl_GetBooleanFromObj(NULL, value2Ptr, &i2); - } - if (result != TCL_OK) { - TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(value2Ptr), - (t2Ptr? t2Ptr->name : "null"))); - IllegalExprOperandType(interp, pc, value2Ptr); - goto checkForCatch; - } + result = TclGetBooleanFromObj(NULL, value2Ptr, &i2); + if (result != TCL_OK) { + TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(value2Ptr), + (value2Ptr->typePtr? value2Ptr->typePtr->name : "null"))); + IllegalExprOperandType(interp, pc, value2Ptr); + goto checkForCatch; } - /* - * Reuse the valuePtr object already on stack if possible. - */ - if (*pc == INST_LOR) { iResult = (i1 || i2); } else { iResult = (i1 && i2); } - if (Tcl_IsShared(valuePtr)) { - TclNewLongObj(objResultPtr, iResult); - TRACE(("%.20s %.20s => %d\n", O2S(valuePtr), O2S(value2Ptr), iResult)); - NEXT_INST_F(1, 2, 1); - } else { /* reuse the valuePtr object */ - TRACE(("%.20s %.20s => %d\n", O2S(valuePtr), O2S(value2Ptr), iResult)); - TclSetLongObj(valuePtr, iResult); - NEXT_INST_F(1, 1, 0); - } + objResultPtr = eePtr->constants[iResult]; + TRACE(("%.20s %.20s => %d\n", O2S(valuePtr), O2S(value2Ptr), iResult)); + NEXT_INST_F(1, 2, 1); } /* @@ -2930,6 +3027,7 @@ TclExecuteByteCode(interp, codePtr) value2Ptr = *tosPtr; valuePtr = *(tosPtr - 1); + /* TODO: Consider more efficient tests than strcmp() */ s1 = Tcl_GetStringFromObj(valuePtr, &s1len); result = Tcl_ListObjLength(interp, value2Ptr, &llen); if (result != TCL_OK) { @@ -2963,6 +3061,8 @@ TclExecuteByteCode(interp, codePtr) /* * Peep-hole optimisation: if you're about to jump, do jump from here. + * We're saving the effort of pushing a boolean value only to pop it + * for branching. */ pc++; @@ -2978,7 +3078,7 @@ TclExecuteByteCode(interp, codePtr) NEXT_INST_F((found ? TclGetInt4AtPtr(pc+1) : 5), 2, 0); } #endif - TclNewIntObj(objResultPtr, found); + objResultPtr = eePtr->constants[found]; NEXT_INST_F(0, 2, 1); } @@ -2991,6 +3091,7 @@ TclExecuteByteCode(interp, codePtr) case INST_STR_NEQ: { /* * String (in)equality check + * TODO: Consider merging into INST_STR_CMP */ int iResult; Tcl_Obj *valuePtr, *value2Ptr; @@ -3057,6 +3158,7 @@ TclExecuteByteCode(interp, codePtr) int s1len, s2len, iResult; Tcl_Obj *valuePtr, *value2Ptr; + stringCompare: value2Ptr = *tosPtr; valuePtr = *(tosPtr - 1); @@ -3108,18 +3210,44 @@ TclExecuteByteCode(interp, codePtr) /* * Make sure only -1,0,1 is returned + * TODO: consider peephole opt. */ if (iResult == 0) { iResult = s1len - s2len; } + + if (*pc != INST_STR_CMP) { + /* Take care of the opcodes that goto'ed into here */ + switch (*pc) { + case INST_EQ: + iResult = (iResult == 0); + break; + case INST_NEQ: + iResult = (iResult != 0); + break; + case INST_LT: + iResult = (iResult < 0); + break; + case INST_GT: + iResult = (iResult > 0); + break; + case INST_LE: + iResult = (iResult <= 0); + break; + case INST_GE: + iResult = (iResult >= 0); + break; + } + } if (iResult < 0) { - iResult = -1; - } else if (iResult > 0) { - iResult = 1; + TclNewIntObj(objResultPtr, -1); + TRACE(("%.20s %.20s => %d\n", O2S(valuePtr), O2S(value2Ptr), -1)); + } else { + objResultPtr = eePtr->constants[(iResult>0)]; + TRACE(("%.20s %.20s => %d\n", O2S(valuePtr), O2S(value2Ptr), + (iResult > 0))); } - TclNewIntObj(objResultPtr, iResult); - TRACE(("%.20s %.20s => %d\n", O2S(valuePtr), O2S(value2Ptr), iResult)); NEXT_INST_F(1, 2, 1); } @@ -3230,6 +3358,7 @@ TclExecuteByteCode(interp, codePtr) /* * Reuse value2Ptr object already on stack if possible. Adjustment is * 2 due to the nocase byte + * TODO: consider peephole opt. */ TRACE(("%.20s %.20s => %d\n", O2S(valuePtr), O2S(value2Ptr), match)); @@ -3243,251 +3372,293 @@ TclExecuteByteCode(interp, codePtr) case INST_GT: case INST_LE: case INST_GE: { - /* - * Any type is allowed but the two operands must have the same type. - * We will compute value op value2. - */ - - Tcl_ObjType *t1Ptr, *t2Ptr; - char *s1 = NULL; /* Init. avoids compiler warning. */ - char *s2 = NULL; /* Init. avoids compiler warning. */ - long i2 = 0; /* Init. avoids compiler warning. */ - double d1 = 0.0; /* Init. avoids compiler warning. */ - double d2 = 0.0; /* Init. avoids compiler warning. */ - long iResult = 0; /* Init. avoids compiler warning. */ - Tcl_Obj *valuePtr, *value2Ptr; - int length; - Tcl_WideInt w; - long i; - - value2Ptr = *tosPtr; - valuePtr = *(tosPtr - 1); - - /* - * Be careful in the equal-object case; 'NaN' isn't supposed to be - * equal to even itself. [Bug 761471] - */ - - t1Ptr = valuePtr->typePtr; + Tcl_Obj *valuePtr = *(tosPtr - 1); + Tcl_Obj *value2Ptr = *tosPtr; + ClientData ptr1, ptr2; + int iResult, compare, type1, type2; + double d1, d2, tmp; + long l1, l2; + Tcl_WideInt w1, w2; + mp_int big1, big2; + + if (GetNumberFromObj(NULL, valuePtr, &ptr1, &type1) != TCL_OK) { + /* At least one non-numeric argument - compare as strings */ + goto stringCompare; + } + if (type1 == TCL_NUMBER_NAN) { + /* NaN first arg: NaN != to everything, other compares are false */ + iResult = (*pc == INST_NEQ); + goto foundResult; + } if (valuePtr == value2Ptr) { - /* - * If we are numeric already, or a dictionary (which is never like - * a single-element list), we can proceed to the main equality - * check right now. Otherwise, we need to try to coerce to a - * numeric type so we can see if we've got a NaN but haven't - * parsed it as numeric. - */ - if (!IS_NUMERIC_TYPE(t1Ptr) && (t1Ptr != &tclDictType)) { - if (t1Ptr == &tclListType) { - int length; - /* - * Only a list of length 1 can be NaN or such things. - */ - (void) Tcl_ListObjLength(NULL, valuePtr, &length); - if (length == 1) { - goto mustConvertForNaNCheck; - } - } else { - /* - * Too bad, we'll have to compute the string and try the - * conversion - */ - - mustConvertForNaNCheck: - s1 = Tcl_GetStringFromObj(valuePtr, &length); - if (TclLooksLikeInt(s1, length)) { - GET_WIDE_OR_INT(iResult, valuePtr, i, w); - } else { - (void) Tcl_GetDoubleFromObj((Tcl_Interp *) NULL, - valuePtr, &d1); - } - t1Ptr = valuePtr->typePtr; - } - } - - switch (*pc) { - case INST_EQ: - case INST_LE: - case INST_GE: - iResult = !((t1Ptr == &tclDoubleType) - && IS_NAN(valuePtr->internalRep.doubleValue)); - break; - case INST_LT: - case INST_GT: - iResult = 0; - break; - case INST_NEQ: - iResult = ((t1Ptr == &tclDoubleType) - && IS_NAN(valuePtr->internalRep.doubleValue)); - break; - } + compare = MP_EQ; + goto convertComparison; + } + if (GetNumberFromObj(NULL, value2Ptr, &ptr2, &type2) != TCL_OK) { + /* At least one non-numeric argument - compare as strings */ + goto stringCompare; + } + if (type2 == TCL_NUMBER_NAN) { + /* NaN 2nd arg: NaN != to everything, other compares are false */ + iResult = (*pc == INST_NEQ); goto foundResult; } - - t2Ptr = value2Ptr->typePtr; - - /* - * We only want to coerce numeric validation if neither type is NULL. - * A NULL type means the arg is essentially an empty object ("", {} or - * [list]). - */ - if (!( (!t1Ptr && !valuePtr->bytes) - || (valuePtr->bytes && !valuePtr->length) - || (!t2Ptr && !value2Ptr->bytes) - || (value2Ptr->bytes && !value2Ptr->length))) { - if (!IS_NUMERIC_TYPE(t1Ptr)) { - s1 = Tcl_GetStringFromObj(valuePtr, &length); - if (TclLooksLikeInt(s1, length)) { - GET_WIDE_OR_INT(iResult, valuePtr, i, w); + switch (type1) { + case TCL_NUMBER_LONG: + l1 = *((CONST long *)ptr1); + switch (type2) { + case TCL_NUMBER_LONG: + l2 = *((CONST long *)ptr2); + longCompare: + compare = (l1 < l2) ? MP_LT : ((l1 > l2) ? MP_GT : MP_EQ); + break; +#ifndef NO_WIDE_TYPE + case TCL_NUMBER_WIDE: + w2 = *((CONST Tcl_WideInt *)ptr2); + w1 = (Tcl_WideInt)l1; + goto wideCompare; +#endif + case TCL_NUMBER_DOUBLE: + d2 = *((CONST double *)ptr2); + d1 = (double) l1; + + /* + * If the double has a fractional part, or if the + * long can be converted to double without loss of + * precision, then compare as doubles. + */ + if ((DBL_MANT_DIG > CHAR_BIT*sizeof(long)) + || (l1 == (long) d1) || (modf(d2, &tmp) != 0.0)) { + goto doubleCompare; + } + /* + * Otherwise, to make comparision based on full precision, + * need to convert the double to a suitably sized integer. + * + * Need this to get comparsions like + * expr 20000000000000003 < 20000000000000004.0 + * right. Converting the first argument to double + * will yield two double values that are equivalent + * within double precision. Converting the double to + * an integer gets done exactly, then integer comparison + * can tell the difference. + */ + if (d2 < (double)LONG_MIN) { + compare = MP_GT; + break; + } + if (d2 > (double)LONG_MAX) { + compare = MP_LT; + break; + } + l2 = (long) d2; + goto longCompare; + case TCL_NUMBER_BIG: + if (Tcl_IsShared(value2Ptr)) { + Tcl_GetBignumFromObj(NULL, value2Ptr, &big2); } else { - (void) Tcl_GetDoubleFromObj((Tcl_Interp *) NULL, - valuePtr, &d1); + Tcl_GetBignumAndClearObj(NULL, value2Ptr, &big2); } - t1Ptr = valuePtr->typePtr; - } - if (!IS_NUMERIC_TYPE(t2Ptr)) { - s2 = Tcl_GetStringFromObj(value2Ptr, &length); - if (TclLooksLikeInt(s2, length)) { - GET_WIDE_OR_INT(iResult, value2Ptr, i2, w); + if (mp_cmp_d(&big2, 0) == MP_LT) { + compare = MP_GT; } else { - (void) Tcl_GetDoubleFromObj((Tcl_Interp *) NULL, - value2Ptr, &d2); + compare = MP_LT; } - t2Ptr = value2Ptr->typePtr; + mp_clear(&big2); } - } - if (!IS_NUMERIC_TYPE(t1Ptr) || !IS_NUMERIC_TYPE(t2Ptr)) { - /* - * One operand is not numeric. Compare as strings. NOTE: strcmp - * is not correct for \x00 < \x01, but that is unlikely to occur - * here. We could use the TclUtfNCmp2 to handle this. - */ - int s1len, s2len; - s1 = Tcl_GetStringFromObj(valuePtr, &s1len); - s2 = Tcl_GetStringFromObj(value2Ptr, &s2len); - switch (*pc) { - case INST_EQ: - if (s1len == s2len) { - iResult = (strcmp(s1, s2) == 0); + break; + +#ifndef NO_WIDE_TYPE + case TCL_NUMBER_WIDE: + w1 = *((CONST Tcl_WideInt *)ptr1); + switch (type2) { + case TCL_NUMBER_WIDE: + w2 = *((CONST Tcl_WideInt *)ptr2); + wideCompare: + compare = (w1 < w2) ? MP_LT : ((w1 > w2) ? MP_GT : MP_EQ); + break; + case TCL_NUMBER_LONG: + l2 = *((CONST long *)ptr2); + w2 = (Tcl_WideInt)l2; + goto wideCompare; + case TCL_NUMBER_DOUBLE: + d2 = *((CONST double *)ptr2); + d1 = (double) w1; + if ((DBL_MANT_DIG > CHAR_BIT*sizeof(Tcl_WideInt)) + || (w1 == (Tcl_WideInt) d1) || (modf(d2, &tmp) != 0.0)) { + goto doubleCompare; + } + if (d2 < (double)LLONG_MIN) { + compare = MP_GT; + break; + } + if (d2 > (double)LLONG_MAX) { + compare = MP_LT; + break; + } + w2 = (Tcl_WideInt) d2; + goto wideCompare; + case TCL_NUMBER_BIG: + if (Tcl_IsShared(value2Ptr)) { + Tcl_GetBignumFromObj(NULL, value2Ptr, &big2); } else { - iResult = 0; + Tcl_GetBignumAndClearObj(NULL, value2Ptr, &big2); } - break; - case INST_NEQ: - if (s1len == s2len) { - iResult = (strcmp(s1, s2) != 0); + if (mp_cmp_d(&big2, 0) == MP_LT) { + compare = MP_GT; } else { - iResult = 1; + compare = MP_LT; } - break; - case INST_LT: - iResult = (strcmp(s1, s2) < 0); - break; - case INST_GT: - iResult = (strcmp(s1, s2) > 0); - break; - case INST_LE: - iResult = (strcmp(s1, s2) <= 0); - break; - case INST_GE: - iResult = (strcmp(s1, s2) >= 0); - break; + mp_clear(&big2); } - } else if ((t1Ptr == &tclDoubleType) || (t2Ptr == &tclDoubleType)) { - /* - * Compare as doubles. - */ - if (t1Ptr == &tclDoubleType) { - d1 = valuePtr->internalRep.doubleValue; - GET_DOUBLE_VALUE(d2, value2Ptr, t2Ptr); - } else { /* t1Ptr is integer, t2Ptr is double */ - GET_DOUBLE_VALUE(d1, valuePtr, t1Ptr); - d2 = value2Ptr->internalRep.doubleValue; - } - switch (*pc) { - case INST_EQ: - iResult = d1 == d2; - break; - case INST_NEQ: - iResult = d1 != d2; - break; - case INST_LT: - iResult = d1 < d2; - break; - case INST_GT: - iResult = d1 > d2; - break; - case INST_LE: - iResult = d1 <= d2; - break; - case INST_GE: - iResult = d1 >= d2; + break; +#endif + + case TCL_NUMBER_DOUBLE: + d1 = *((CONST double *)ptr1); + switch (type2) { + case TCL_NUMBER_DOUBLE: + d2 = *((CONST double *)ptr2); + doubleCompare: + compare = (d1 < d2) ? MP_LT : ((d1 > d2) ? MP_GT : MP_EQ); break; + case TCL_NUMBER_LONG: + l2 = *((CONST long *)ptr2); + d2 = (double) l2; + + if ((DBL_MANT_DIG > CHAR_BIT*sizeof(long)) + || (l2 == (long) d2) || (modf(d1, &tmp) != 0.0)) { + goto doubleCompare; + } + if (d1 < (double)LONG_MIN) { + compare = MP_LT; + break; + } + if (d1 > (double)LONG_MAX) { + compare = MP_GT; + break; + } + l1 = (long) d1; + goto longCompare; +#ifndef NO_WIDE_TYPE + case TCL_NUMBER_WIDE: + w2 = *((CONST Tcl_WideInt *)ptr2); + d2 = (double) w2; + if ((DBL_MANT_DIG > CHAR_BIT*sizeof(Tcl_WideInt)) + || (w2 == (Tcl_WideInt) d2) || (modf(d1, &tmp) != 0.0)) { + goto doubleCompare; + } + if (d1 < (double)LLONG_MIN) { + compare = MP_LT; + break; + } + if (d1 > (double)LLONG_MAX) { + compare = MP_GT; + break; + } + w1 = (Tcl_WideInt) d1; + goto wideCompare; +#endif + case TCL_NUMBER_BIG: + if (TclIsInfinite(d1)) { + compare = (d1 > 0.0) ? MP_GT : MP_LT; + break; + } + if (Tcl_IsShared(value2Ptr)) { + Tcl_GetBignumFromObj(NULL, value2Ptr, &big2); + } else { + Tcl_GetBignumAndClearObj(NULL, value2Ptr, &big2); + } + if ((d1 < (double)LONG_MAX) && (d1 > (double)LONG_MIN)) { + if (mp_cmp_d(&big2, 0) == MP_LT) { + compare = MP_GT; + } else { + compare = MP_LT; + } + mp_clear(&big2); + break; + } + if ((DBL_MANT_DIG > CHAR_BIT*sizeof(long)) + && (modf(d1, &tmp) != 0.0)) { + d2 = TclBignumToDouble( &big2); + mp_clear(&big2); + goto doubleCompare; + } + TclInitBignumFromDouble(NULL, d1, &big1); + goto bigCompare; } - } else if ((t1Ptr == &tclWideIntType) || (t2Ptr == &tclWideIntType)) { - Tcl_WideInt w2; - /* - * Compare as wide ints (neither are doubles) - */ - if (t1Ptr == &tclIntType) { - w = Tcl_LongAsWide(valuePtr->internalRep.longValue); - TclGetWide(w2,value2Ptr); - } else if (t2Ptr == &tclIntType) { - TclGetWide(w,valuePtr); - w2 = Tcl_LongAsWide(value2Ptr->internalRep.longValue); + break; + + case TCL_NUMBER_BIG: + if (Tcl_IsShared(valuePtr)) { + Tcl_GetBignumFromObj(NULL, valuePtr, &big1); } else { - TclGetWide(w,valuePtr); - TclGetWide(w2,value2Ptr); + Tcl_GetBignumAndClearObj(NULL, valuePtr, &big1); } - switch (*pc) { - case INST_EQ: - iResult = w == w2; - break; - case INST_NEQ: - iResult = w != w2; - break; - case INST_LT: - iResult = w < w2; - break; - case INST_GT: - iResult = w > w2; - break; - case INST_LE: - iResult = w <= w2; - break; - case INST_GE: - iResult = w >= w2; - break; - } - } else { - /* - * Compare as ints. - */ - i = valuePtr->internalRep.longValue; - i2 = value2Ptr->internalRep.longValue; - switch (*pc) { - case INST_EQ: - iResult = i == i2; - break; - case INST_NEQ: - iResult = i != i2; - break; - case INST_LT: - iResult = i < i2; - break; - case INST_GT: - iResult = i > i2; - break; - case INST_LE: - iResult = i <= i2; - break; - case INST_GE: - iResult = i >= i2; + switch (type2) { +#ifndef NO_WIDE_TYPE + case TCL_NUMBER_WIDE: +#endif + case TCL_NUMBER_LONG: + compare = mp_cmp_d(&big1, 0); + mp_clear(&big1); break; + case TCL_NUMBER_DOUBLE: + d2 = *((CONST double *)ptr2); + if (TclIsInfinite(d2)) { + compare = (d2 > 0.0) ? MP_LT : MP_GT; + mp_clear(&big1); + break; + } + if ((d2 < (double)LONG_MAX) && (d2 > (double)LONG_MIN)) { + compare = mp_cmp_d(&big1, 0); + mp_clear(&big1); + break; + } + if ((DBL_MANT_DIG > CHAR_BIT*sizeof(long)) + && (modf(d2, &tmp) != 0.0)) { + d1 = TclBignumToDouble( &big1); + mp_clear(&big1); + goto doubleCompare; + } + TclInitBignumFromDouble(NULL, d2, &big2); + goto bigCompare; + case TCL_NUMBER_BIG: + if (Tcl_IsShared(value2Ptr)) { + Tcl_GetBignumFromObj(NULL, value2Ptr, &big2); + } else { + Tcl_GetBignumAndClearObj(NULL, value2Ptr, &big2); + } + bigCompare: + compare = mp_cmp(&big1, &big2); + mp_clear(&big1); + mp_clear(&big2); } } - TRACE(("%.20s %.20s => %ld\n", O2S(valuePtr), O2S(value2Ptr), iResult)); + /* Turn comparison outcome into appropriate result for opcode */ + + convertComparison: + switch (*pc) { + case INST_EQ: + iResult = (compare == MP_EQ); + break; + case INST_NEQ: + iResult = (compare != MP_EQ); + break; + case INST_LT: + iResult = (compare == MP_LT); + break; + case INST_GT: + iResult = (compare == MP_GT); + break; + case INST_LE: + iResult = (compare != MP_GT); + break; + case INST_GE: + iResult = (compare != MP_LT); + break; + } /* * Peep-hole optimisation: if you're about to jump, do jump from here. @@ -3511,12 +3682,445 @@ TclExecuteByteCode(interp, codePtr) NEXT_INST_F(0, 2, 1); } - case INST_MOD: case INST_LSHIFT: - case INST_RSHIFT: + case INST_RSHIFT: { + Tcl_Obj *value2Ptr = *tosPtr; + Tcl_Obj *valuePtr = *(tosPtr - 1); + ClientData ptr1, ptr2; + int invalid, shift, type1, type2; + long l; + + result = GetNumberFromObj(NULL, valuePtr, &ptr1, &type1); + if ((result != TCL_OK) + || (type1 == TCL_NUMBER_DOUBLE) || (type1 == TCL_NUMBER_NAN)) { + result = TCL_ERROR; + TRACE(("%.20s %.20s => ILLEGAL 1st TYPE %s\n", O2S(valuePtr), + O2S(value2Ptr), (valuePtr->typePtr? + valuePtr->typePtr->name : "null"))); + IllegalExprOperandType(interp, pc, valuePtr); + goto checkForCatch; + } + + result = GetNumberFromObj(NULL, value2Ptr, &ptr2, &type2); + if ((result != TCL_OK) + || (type2 == TCL_NUMBER_DOUBLE) || (type2 == TCL_NUMBER_NAN)) { + result = TCL_ERROR; + TRACE(("%.20s %.20s => ILLEGAL 2nd TYPE %s\n", O2S(valuePtr), + O2S(value2Ptr), (value2Ptr->typePtr? + value2Ptr->typePtr->name : "null"))); + IllegalExprOperandType(interp, pc, value2Ptr); + goto checkForCatch; + } + + /* reject negative shift argument */ + switch (type2) { + case TCL_NUMBER_LONG: + invalid = (*((CONST long *)ptr2) < (long)0); + break; +#ifndef NO_WIDE_TYPE + case TCL_NUMBER_WIDE: + invalid = (*((CONST Tcl_WideInt *)ptr2) < (Tcl_WideInt)0); + break; +#endif + case TCL_NUMBER_BIG: + /* TODO: const correctness ? */ + invalid = (mp_cmp_d((mp_int *)ptr2, 0) == MP_LT); + } + if (invalid) { + Tcl_SetObjResult(interp, + Tcl_NewStringObj("negative shift argument", -1)); + result = TCL_ERROR; + goto checkForCatch; + } + + /* Zero shifted any number of bits is still zero */ + if ((type1 == TCL_NUMBER_LONG) && (*((CONST long *)ptr1) == (long)0)) { + TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); + objResultPtr = eePtr->constants[0]; + TRACE(("%s\n", O2S(objResultPtr))); + NEXT_INST_F(1, 2, 1); + } + + if (*pc == INST_LSHIFT) { + /* Large left shifts create integer overflow */ + result = Tcl_GetIntFromObj(NULL, value2Ptr, &shift); + if (result != TCL_OK) { + /* + * Technically, we could hold the value (1 << (INT_MAX+1)) + * in an mp_int, but since we're using mp_mul_2d() to do the + * work, and it takes only an int argument, that's a good + * place to draw the line. + */ + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "integer value too large to represent", -1)); + goto checkForCatch; + } + /* Handle shifts within the native long range */ + TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); + if ((type1 == TCL_NUMBER_LONG) && (shift < CHAR_BIT*sizeof(long)) + && (l = *((CONST long *)ptr1)) + && !(((l>0) ? l : ~l) + & -(1<<(CHAR_BIT*sizeof(long)-1-shift)))) { + TclNewLongObj(objResultPtr, (l<<shift)); + TRACE(("%s\n", O2S(objResultPtr))); + NEXT_INST_F(1, 2, 1); + } + + /* Handle shifts within the native wide range */ + TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); + if ((type1 != TCL_NUMBER_BIG) + && (shift < CHAR_BIT*sizeof(Tcl_WideInt))) { + Tcl_WideInt w; + TclGetWideIntFromObj(NULL, valuePtr, &w); + if (!(((w>0) ? w : ~w) + & -(((Tcl_WideInt)1) + <<(CHAR_BIT*sizeof(Tcl_WideInt)-1-shift)))) { + objResultPtr = Tcl_NewWideIntObj(w<<shift); + TRACE(("%s\n", O2S(objResultPtr))); + NEXT_INST_F(1, 2, 1); + } + } + +/* + if ((type1 == TCL_NUMBER_LONG) && (shift < CHAR_BIT*sizeof(long)) + && (l = *((CONST long *)ptr1)) + && !(((l>0) ? l : ~l) + & -(1<<(CHAR_BIT*sizeof(long)-1-shift)))) { + TclNewLongObj(objResultPtr, (l<<shift)); + TRACE(("%s\n", O2S(objResultPtr))); + NEXT_INST_F(1, 2, 1); + } +*/ + + + + } else { + /* Quickly force large right shifts to 0 or -1 */ + TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); + if ((type2 != TCL_NUMBER_LONG) + || ( *((CONST long *)ptr2) > INT_MAX)) { + /* + * Again, technically, the value to be shifted could + * be an mp_int so huge that a right shift by (INT_MAX+1) + * bits could not take us to the result of 0 or -1, but + * since we're using mp_div_2d to do the work, and it + * takes only an int argument, we draw the line there. + */ + int zero; + switch (type1) { + case TCL_NUMBER_LONG: + zero = (*((CONST long *)ptr1) > (long)0); + break; +#ifndef NO_WIDE_TYPE + case TCL_NUMBER_WIDE: + zero = (*((CONST Tcl_WideInt *)ptr1) > (Tcl_WideInt)0); + break; +#endif + case TCL_NUMBER_BIG: + /* TODO: const correctness ? */ + zero = (mp_cmp_d((mp_int *)ptr1, 0) == MP_GT); + } + if (zero) { + objResultPtr = eePtr->constants[0]; + } else { + TclNewIntObj(objResultPtr, -1); + } + TRACE(("%s\n", O2S(objResultPtr))); + NEXT_INST_F(1, 2, 1); + } + shift = (int)(*((CONST long *)ptr2)); + /* Handle shifts within the native long range */ + if (type1 == TCL_NUMBER_LONG) { + long l = *((CONST long *)ptr1); + if (shift >= CHAR_BIT*sizeof(long)) { + if (l >= (long)0) { + objResultPtr = eePtr->constants[0]; + } else { + TclNewIntObj(objResultPtr, -1); + } + } else { + TclNewLongObj(objResultPtr, (l >> shift)); + } + TRACE(("%s\n", O2S(objResultPtr))); + NEXT_INST_F(1, 2, 1); + } +#ifndef NO_WIDE_TYPE + /* Handle shifts within the native wide range */ + if (type1 == TCL_NUMBER_WIDE) { + Tcl_WideInt w = *((CONST Tcl_WideInt *)ptr1); + if (shift >= CHAR_BIT*sizeof(Tcl_WideInt)) { + if (w >= (Tcl_WideInt)0) { + objResultPtr = eePtr->constants[0]; + } else { + TclNewIntObj(objResultPtr, -1); + } + } else { + objResultPtr = Tcl_NewWideIntObj(w >> shift); + } + TRACE(("%s\n", O2S(objResultPtr))); + NEXT_INST_F(1, 2, 1); + } +#endif + } + + { + mp_int big, bigResult, bigRemainder; + + if (Tcl_IsShared(valuePtr)) { + Tcl_GetBignumFromObj(NULL, valuePtr, &big); + } else { + Tcl_GetBignumAndClearObj(NULL, valuePtr, &big); + } + + mp_init(&bigResult); + if (*pc == INST_LSHIFT) { + mp_mul_2d(&big, shift, &bigResult); + } else { + mp_init(&bigRemainder); + mp_div_2d(&big, shift, &bigResult, &bigRemainder); + if (mp_cmp_d(&bigRemainder, 0) == MP_LT) { + /* Convert to Tcl's integer division rules */ + mp_sub_d(&bigResult, 1, &bigResult); + } + mp_clear(&bigRemainder); + } + mp_clear(&big); + + if (!Tcl_IsShared(valuePtr)) { + Tcl_SetBignumObj(valuePtr, &bigResult); + TRACE(("%s\n", O2S(valuePtr))); + NEXT_INST_F(1, 1, 0); + } + objResultPtr = Tcl_NewBignumObj(&bigResult); + } + TRACE(("%s\n", O2S(objResultPtr))); + NEXT_INST_F(1, 2, 1); + } + case INST_BITOR: case INST_BITXOR: case INST_BITAND: { + ClientData ptr1, ptr2; + int type1, type2; + Tcl_Obj *value2Ptr = *tosPtr; + Tcl_Obj *valuePtr = *(tosPtr - 1); + + result = GetNumberFromObj(NULL, valuePtr, &ptr1, &type1); + if ((result != TCL_OK) + || (type1 == TCL_NUMBER_NAN) || (type1 == TCL_NUMBER_DOUBLE)) { + result = TCL_ERROR; + TRACE(("%.20s %.20s => ILLEGAL 1st TYPE %s\n", O2S(valuePtr), + O2S(value2Ptr), (valuePtr->typePtr? + valuePtr->typePtr->name : "null"))); + IllegalExprOperandType(interp, pc, valuePtr); + goto checkForCatch; + } + result = GetNumberFromObj(NULL, value2Ptr, &ptr2, &type2); + if ((result != TCL_OK) + || (type2 == TCL_NUMBER_NAN) || (type2 == TCL_NUMBER_DOUBLE)) { + result = TCL_ERROR; + TRACE(("%.20s %.20s => ILLEGAL 2nd TYPE %s\n", O2S(valuePtr), + O2S(value2Ptr), (value2Ptr->typePtr? + value2Ptr->typePtr->name : "null"))); + IllegalExprOperandType(interp, pc, value2Ptr); + goto checkForCatch; + } + + if ((type1 == TCL_NUMBER_BIG) || (type2 == TCL_NUMBER_BIG)) { + mp_int big1, big2, bigResult; + mp_int *Pos, *Neg, *Other; + int numPos = 0; + + if (Tcl_IsShared(valuePtr)) { + Tcl_GetBignumFromObj(NULL, valuePtr, &big1); + } else { + Tcl_GetBignumAndClearObj(NULL, valuePtr, &big1); + } + if (Tcl_IsShared(value2Ptr)) { + Tcl_GetBignumFromObj(NULL, value2Ptr, &big2); + } else { + Tcl_GetBignumAndClearObj(NULL, value2Ptr, &big2); + } + + if (mp_cmp_d(&big1, 0) != MP_LT) { + numPos++; + Pos = &big1; + if (mp_cmp_d(&big2, 0) != MP_LT) { + numPos++; + Other = &big2; + } else { + Neg = &big2; + } + } else { + Neg = &big1; + if (mp_cmp_d(&big2, 0) != MP_LT) { + numPos++; + Pos = &big2; + } else { + Other = &big2; + } + } + mp_init(&bigResult); + + switch (*pc) { + case INST_BITAND: + switch (numPos) { + case 2: + /* Both arguments positive, base case */ + mp_and(Pos, Other, &bigResult); + break; + case 1: + /* One arg positive; one negative + * P & N = P & ~~N = P&~(-N-1) = P & (P ^ (-N-1)) */ + mp_neg(Neg, Neg); + mp_sub_d(Neg, 1, Neg); + mp_xor(Pos, Neg, &bigResult); + mp_and(Pos, &bigResult, &bigResult); + break; + case 0: + /* Both arguments negative + * a & b = ~ (~a | ~b) = -(-a-1|-b-1)-1 */ + mp_neg(Neg, Neg); + mp_sub_d(Neg, 1, Neg); + mp_neg(Other, Other); + mp_sub_d(Other, 1, Other); + mp_or(Neg, Other, &bigResult); + mp_neg(&bigResult, &bigResult); + mp_sub_d(&bigResult, 1, &bigResult); + break; + } + break; + + case INST_BITOR: + switch (numPos) { + case 2: + /* Both arguments positive, base case */ + mp_or(Pos, Other, &bigResult); + break; + case 1: + /* One arg positive; one negative + * N|P = ~(~N&~P) = ~((-N-1)&~P) = -((-N-1)&((-N-1)^P))-1 */ + mp_neg(Neg, Neg); + mp_sub_d(Neg, 1, Neg); + mp_xor(Pos, Neg, &bigResult); + mp_and(Neg, &bigResult, &bigResult); + mp_neg(&bigResult, &bigResult); + mp_sub_d(&bigResult, 1, &bigResult); + break; + case 0: + /* Both arguments negative + * a | b = ~ (~a & ~b) = -(-a-1&-b-1)-1 */ + mp_neg(Neg, Neg); + mp_sub_d(Neg, 1, Neg); + mp_neg(Other, Other); + mp_sub_d(Other, 1, Other); + mp_and(Neg, Other, &bigResult); + mp_neg(&bigResult, &bigResult); + mp_sub_d(&bigResult, 1, &bigResult); + break; + } + break; + + case INST_BITXOR: + switch (numPos) { + case 2: + /* Both arguments positive, base case */ + mp_xor(Pos, Other, &bigResult); + break; + case 1: + /* One arg positive; one negative + * P^N = ~(P^~N) = -(P^(-N-1))-1 + */ + mp_neg(Neg, Neg); + mp_sub_d(Neg, 1, Neg); + mp_xor(Pos, Neg, &bigResult); + mp_neg(&bigResult, &bigResult); + mp_sub_d(&bigResult, 1, &bigResult); + break; + case 0: + /* Both arguments negative + * a ^ b = (~a ^ ~b) = (-a-1^-b-1) */ + mp_neg(Neg, Neg); + mp_sub_d(Neg, 1, Neg); + mp_neg(Other, Other); + mp_sub_d(Other, 1, Other); + mp_xor(Neg, Other, &bigResult); + break; + } + break; + } + + mp_clear(&big1); + mp_clear(&big2); + TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); + if (Tcl_IsShared(valuePtr)) { + objResultPtr = Tcl_NewBignumObj(&bigResult); + TRACE(("%s\n", O2S(objResultPtr))); + NEXT_INST_F(1, 2, 1); + } + Tcl_SetBignumObj(valuePtr, &bigResult); + TRACE(("%s\n", O2S(valuePtr))); + NEXT_INST_F(1, 1, 0); + } + +#ifndef NO_WIDE_TYPE + if ((type1 == TCL_NUMBER_WIDE) || (type2 == TCL_NUMBER_WIDE)) { + Tcl_WideInt wResult, w1, w2; + TclGetWideIntFromObj(NULL, valuePtr, &w1); + TclGetWideIntFromObj(NULL, value2Ptr, &w2); + + switch (*pc) { + case INST_BITAND: + wResult = w1 & w2; + break; + case INST_BITOR: + wResult = w1 | w2; + break; + case INST_BITXOR: + wResult = w1 ^ w2; + } + + TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); + if (Tcl_IsShared(valuePtr)) { + objResultPtr = Tcl_NewWideIntObj(wResult); + TRACE(("%s\n", O2S(objResultPtr))); + NEXT_INST_F(1, 2, 1); + } + Tcl_SetWideIntObj(valuePtr, wResult); + TRACE(("%s\n", O2S(valuePtr))); + NEXT_INST_F(1, 1, 0); + } +#endif + { + long lResult, l1 = *((CONST long *)ptr1); + long l2 = *((CONST long *)ptr2); + + switch (*pc) { + case INST_BITAND: + lResult = l1 & l2; + break; + case INST_BITOR: + lResult = l1 | l2; + break; + case INST_BITXOR: + lResult = l1 ^ l2; + } + + TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); + if (Tcl_IsShared(valuePtr)) { + TclNewLongObj(objResultPtr, lResult); + TRACE(("%s\n", O2S(objResultPtr))); + NEXT_INST_F(1, 2, 1); + } + TclSetLongObj(valuePtr, lResult); + TRACE(("%s\n", O2S(valuePtr))); + NEXT_INST_F(1, 1, 0); + } + } + +#if 0 + case INST_MOD: + { /* * Only integers are allowed. We compute value op value2. */ @@ -3560,8 +4164,7 @@ TclExecuteByteCode(interp, codePtr) } } - switch (*pc) { - case INST_MOD: + do { /* * This code is tricky: C doesn't guarantee much about the * quotient or remainder, and results with a negative divisor are @@ -3691,171 +4294,7 @@ TclExecuteByteCode(interp, codePtr) rem = -rem; } iResult = rem; - break; - case INST_LSHIFT: - /* - * Shifts are never usefully 64-bits wide! - */ - FORCE_LONG(value2Ptr, i2, w2); - if (valuePtr->typePtr == &tclWideIntType) { -#ifdef TCL_COMPILE_DEBUG - w2 = Tcl_LongAsWide(i2); -#endif /* TCL_COMPILE_DEBUG */ - wResult = w; - /* - * Shift in steps when the shift gets large to prevent - * annoying compiler/processor bugs. [Bug 868467] - */ - if (i2 >= 64) { - wResult = Tcl_LongAsWide(0); - } else if (i2 > 60) { - wResult = w << 30; - wResult <<= 30; - wResult <<= i2-60; - } else if (i2 > 30) { - wResult = w << 30; - wResult <<= i2-30; - } else { - wResult = w << i2; - } - doWide = 1; - break; - } - /* - * Shift in steps when the shift gets large to prevent annoying - * compiler/processor bugs. [Bug 868467] - */ - if (i2 >= 64) { - iResult = 0; - } else if (i2 > 60) { - iResult = i << 30; - iResult <<= 30; - iResult <<= i2-60; - } else if (i2 > 30) { - iResult = i << 30; - iResult <<= i2-30; - } else { - iResult = i << i2; - } - break; - case INST_RSHIFT: - /* - * The following code is a bit tricky: it ensures that right - * shifts propagate the sign bit even on machines where ">>" won't - * do it by default. - */ - /* - * Shifts are never usefully 64-bits wide! - */ - FORCE_LONG(value2Ptr, i2, w2); - if (valuePtr->typePtr == &tclWideIntType) { -#ifdef TCL_COMPILE_DEBUG - w2 = Tcl_LongAsWide(i2); -#endif /* TCL_COMPILE_DEBUG */ - if (w < 0) { - wResult = ~w; - } else { - wResult = w; - } - /* - * Shift in steps when the shift gets large to prevent - * annoying compiler/processor bugs. [Bug 868467] - */ - if (i2 >= 64) { - wResult = Tcl_LongAsWide(0); - } else if (i2 > 60) { - wResult >>= 30; - wResult >>= 30; - wResult >>= i2-60; - } else if (i2 > 30) { - wResult >>= 30; - wResult >>= i2-30; - } else { - wResult >>= i2; - } - if (w < 0) { - wResult = ~wResult; - } - doWide = 1; - break; - } - if (i < 0) { - iResult = ~i; - } else { - iResult = i; - } - /* - * Shift in steps when the shift gets large to prevent annoying - * compiler/processor bugs. [Bug 868467] - */ - if (i2 >= 64) { - iResult = 0; - } else if (i2 > 60) { - iResult >>= 30; - iResult >>= 30; - iResult >>= i2-60; - } else if (i2 > 30) { - iResult >>= 30; - iResult >>= i2-30; - } else { - iResult >>= i2; - } - if (i < 0) { - iResult = ~iResult; - } - break; - case INST_BITOR: - if (valuePtr->typePtr == &tclWideIntType - || value2Ptr->typePtr == &tclWideIntType) { - /* - * Promote to wide - */ - if (valuePtr->typePtr == &tclIntType) { - w = Tcl_LongAsWide(i); - } else if (value2Ptr->typePtr == &tclIntType) { - w2 = Tcl_LongAsWide(i2); - } - wResult = w | w2; - doWide = 1; - break; - } - iResult = i | i2; - break; - case INST_BITXOR: - if (valuePtr->typePtr == &tclWideIntType - || value2Ptr->typePtr == &tclWideIntType) { - /* - * Promote to wide - */ - if (valuePtr->typePtr == &tclIntType) { - w = Tcl_LongAsWide(i); - } else if (value2Ptr->typePtr == &tclIntType) { - w2 = Tcl_LongAsWide(i2); - } - wResult = w ^ w2; - doWide = 1; - break; - } - iResult = i ^ i2; - break; - case INST_BITAND: - if (valuePtr->typePtr == &tclWideIntType - || value2Ptr->typePtr == &tclWideIntType) { - /* - * Promote to wide - */ - if (valuePtr->typePtr == &tclIntType) { - w = Tcl_LongAsWide(i); - } else if (value2Ptr->typePtr == &tclIntType) { - w2 = Tcl_LongAsWide(i2); - } - wResult = w & w2; - doWide = 1; - break; - } - iResult = i & i2; - break; - } + } while (0); /* * Reuse the valuePtr object already on stack if possible. @@ -3881,27 +4320,284 @@ TclExecuteByteCode(interp, codePtr) NEXT_INST_F(1, 1, 0); } } +#endif case INST_ADD: case INST_SUB: - case INST_MULT: case INST_DIV: + case INST_MULT: { + ClientData ptr1, ptr2; + int type1, type2; + Tcl_Obj *value2Ptr = *tosPtr; + Tcl_Obj *valuePtr = *(tosPtr - 1); + + result = GetNumberFromObj(NULL, valuePtr, &ptr1, &type1); + if ((result != TCL_OK) +#ifndef ACCEPT_NAN + || (type1 == TCL_NUMBER_NAN) +#endif + ) { + result = TCL_ERROR; + TRACE(("%.20s %.20s => ILLEGAL 1st TYPE %s\n", + O2S(value2Ptr), O2S(valuePtr), + (valuePtr->typePtr? valuePtr->typePtr->name: "null"))); + IllegalExprOperandType(interp, pc, valuePtr); + goto checkForCatch; + } + +#ifdef ACCEPT_NAN + if (type1 == TCL_NUMBER_NAN) { + /* NaN first argument -> result is also NaN */ + NEXT_INST_F(1, 1, 0); + } +#endif + + result = GetNumberFromObj(NULL, value2Ptr, &ptr2, &type2); + if ((result != TCL_OK) +#ifndef ACCEPT_NAN + || (type2 == TCL_NUMBER_NAN) +#endif + ) { + result = TCL_ERROR; + TRACE(("%.20s %.20s => ILLEGAL 2nd TYPE %s\n", + O2S(value2Ptr), O2S(valuePtr), + (value2Ptr->typePtr? value2Ptr->typePtr->name: "null"))); + IllegalExprOperandType(interp, pc, value2Ptr); + goto checkForCatch; + } + +#ifdef ACCEPT_NAN + if (type2 == TCL_NUMBER_NAN) { + /* NaN second argument -> result is also NaN */ + objResultPtr = value2Ptr; + NEXT_INST_F(1, 2, 1); + } +#endif + + if ((type1 == TCL_NUMBER_DOUBLE) || (type2 == TCL_NUMBER_DOUBLE)) { + /* At least one of the values is floating-point, so perform + * floating point calculations */ + double d1, d2, dResult; + Tcl_GetDoubleFromObj(NULL, valuePtr, &d1); + Tcl_GetDoubleFromObj(NULL, value2Ptr, &d2); + + switch (*pc) { + case INST_ADD: + dResult = d1 + d2; + break; + case INST_SUB: + dResult = d1 - d2; + break; + case INST_MULT: + dResult = d1 * d2; + break; + case INST_DIV: +#ifndef IEEE_FLOATING_POINT + if (d2 == 0.0) { + TRACE(("%.6g %.6g => DIVIDE BY ZERO\n", d1, d2)); + goto divideByZero; + } +#endif + /* + * We presume that we are running with zero-divide unmasked if + * we're on an IEEE box. Otherwise, this statement might cause + * demons to fly out our noses. + */ + dResult = d1 / d2; + break; + } + +#ifndef ACCEPT_NAN + /* + * Check now for IEEE floating-point error. + */ + + if (TclIsNaN(dResult)) { + TRACE(("%.20s %.20s => IEEE FLOATING PT ERROR\n", + O2S(valuePtr), O2S(value2Ptr))); + TclExprFloatError(interp, dResult); + result = TCL_ERROR; + goto checkForCatch; + } +#endif + TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); + if (Tcl_IsShared(valuePtr)) { + TclNewDoubleObj(objResultPtr, dResult); + TRACE(("%s\n", O2S(objResultPtr))); + NEXT_INST_F(1, 2, 1); + } + TclSetDoubleObj(valuePtr, dResult); + TRACE(("%s\n", O2S(valuePtr))); + NEXT_INST_F(1, 1, 0); + } + + if ((*pc == INST_MULT) && (sizeof(Tcl_WideInt) >= 2*sizeof(long)) + && (type1 == TCL_NUMBER_LONG) && (type2 == TCL_NUMBER_LONG)) { + Tcl_WideInt w1, w2, wResult; + TclGetWideIntFromObj(NULL, valuePtr, &w1); + TclGetWideIntFromObj(NULL, value2Ptr, &w2); + + wResult = w1 * w2; + + TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); + if (Tcl_IsShared(valuePtr)) { + objResultPtr = Tcl_NewWideIntObj(wResult); + TRACE(("%s\n", O2S(objResultPtr))); + NEXT_INST_F(1, 2, 1); + } + Tcl_SetWideIntObj(valuePtr, wResult); + TRACE(("%s\n", O2S(valuePtr))); + NEXT_INST_F(1, 1, 0); + } + + if ((*pc != INST_MULT) + && (type1 != TCL_NUMBER_BIG) && (type2 != TCL_NUMBER_BIG)) { + Tcl_WideInt w1, w2, wResult; + TclGetWideIntFromObj(NULL, valuePtr, &w1); + TclGetWideIntFromObj(NULL, value2Ptr, &w2); + + switch (*pc) { + case INST_ADD: + wResult = w1 + w2; +#ifndef NO_WIDE_TYPE + if ((type1 == TCL_NUMBER_WIDE) || (type2 == TCL_NUMBER_WIDE)) +#endif + { + /* Check for overflow */ + if (((w1 < 0) && (w2 < 0) && (wResult > 0)) + || ((w1 > 0) && (w2 > 0) && (wResult < 0))) { + goto overflow; + } + } + break; + + case INST_SUB: + wResult = w1 - w2; +#ifndef NO_WIDE_TYPE + if ((type1 == TCL_NUMBER_WIDE) || (type2 == TCL_NUMBER_WIDE)) +#endif + { + /* Must check for overflow */ + if (((w1 < 0) && (w2 > 0) && (wResult > 0)) + || ((w1 > 0) && (w2 < 0) && (wResult < 0))) { + goto overflow; + } + } + break; + + case INST_DIV: + if (w2 == 0) { + TRACE(("%s %s => DIVIDE BY ZERO\n", + O2S(valuePtr), O2S(value2Ptr))); + goto divideByZero; + } + + /* Need a bignum to represent (LLONG_MIN / -1) */ + if ((w1 == LLONG_MIN) && (w2 == -1)) { + goto overflow; + } + wResult = w1 / w2; + + /* Force Tcl's integer division rules */ + /* TODO: examine for logic simplification */ + if (((wResult < 0) || ((wResult == 0) && + ((w1 < 0 && w2 > 0) || (w1 > 0 && w2 < 0)))) && + ((wResult * w2) != w1)) { + wResult -= 1; + } + break; + } + + TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); + if (Tcl_IsShared(valuePtr)) { + objResultPtr = Tcl_NewWideIntObj(wResult); + TRACE(("%s\n", O2S(objResultPtr))); + NEXT_INST_F(1, 2, 1); + } + Tcl_SetWideIntObj(valuePtr, wResult); + TRACE(("%s\n", O2S(valuePtr))); + NEXT_INST_F(1, 1, 0); + } + + overflow: + { + mp_int big1, big2, bigResult, bigRemainder; + TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); + if (Tcl_IsShared(valuePtr)) { + Tcl_GetBignumFromObj(NULL, valuePtr, &big1); + } else { + Tcl_GetBignumAndClearObj(NULL, valuePtr, &big1); + } + if (Tcl_IsShared(value2Ptr)) { + Tcl_GetBignumFromObj(NULL, value2Ptr, &big2); + } else { + Tcl_GetBignumAndClearObj(NULL, value2Ptr, &big2); + } + mp_init(&bigResult); + switch (*pc) { + case INST_ADD: + mp_add(&big1, &big2, &bigResult); + break; + case INST_SUB: + mp_sub(&big1, &big2, &bigResult); + break; + case INST_MULT: + mp_mul(&big1, &big2, &bigResult); + break; + case INST_DIV: + if (mp_iszero(&big2)) { + TRACE(("%s %s => DIVIDE BY ZERO\n", O2S(valuePtr), + O2S(value2Ptr))); + mp_clear(&big1); + mp_clear(&big2); + goto divideByZero; + } + mp_init(&bigRemainder); + mp_div(&big1, &big2, &bigResult, &bigRemainder); + /* TODO: internals intrusion */ + if (!mp_iszero(&bigRemainder) + && (bigRemainder.sign != big2.sign)) { + /* Convert to Tcl's integer division rules */ + mp_sub_d(&bigResult, 1, &bigResult); + mp_add(&bigRemainder, &big2, &bigRemainder); + } + if (*pc == INST_MOD) { + mp_copy(&bigRemainder, &bigResult); + } + mp_clear(&bigRemainder); + break; + } + mp_clear(&big1); + mp_clear(&big2); + if (Tcl_IsShared(valuePtr)) { + objResultPtr = Tcl_NewBignumObj(&bigResult); + TRACE(("%s\n", O2S(objResultPtr))); + NEXT_INST_F(1, 2, 1); + } + Tcl_SetBignumObj(valuePtr, &bigResult); + TRACE(("%s\n", O2S(valuePtr))); + NEXT_INST_F(1, 1, 0); + } + } + + case INST_MOD: case INST_EXPON: { /* * Operands must be numeric and ints get converted to floats if * necessary. We compute value op value2. */ + double d1, d2; + double dResult = 0.0; /* Init. avoids compiler warning. */ + Tcl_Obj *valuePtr,*value2Ptr; +#if 0 Tcl_ObjType *t1Ptr, *t2Ptr; long i = 0, i2 = 0, quot; /* Init. avoids compiler warning. */ - double d1, d2; long iResult = 0; /* Init. avoids compiler warning. */ - double dResult = 0.0; /* Init. avoids compiler warning. */ int doDouble = 0; /* 1 if doing floating arithmetic */ Tcl_WideInt w, w2, wquot; Tcl_WideInt wResult = W0; /* Init. avoids compiler warning. */ int doWide = 0; /* 1 if doing wide arithmetic. */ - Tcl_Obj *valuePtr,*value2Ptr; int length; value2Ptr = *tosPtr; @@ -3994,20 +4690,6 @@ TclExecuteByteCode(interp, codePtr) case INST_MULT: dResult = d1 * d2; break; - case INST_DIV: -#ifndef IEEE_FLOATING_POINT - if (d2 == 0.0) { - TRACE(("%.6g %.6g => DIVIDE BY ZERO\n", d1, d2)); - goto divideByZero; - } -#endif - /* - * We presume that we are running with zero-divide unmasked if - * we're on an IEEE box. Otherwise, this statement might cause - * demons to fly out our noses. - */ - dResult = d1 / d2; - break; case INST_EXPON: if (d1==0.0 && d2<0.0) { TRACE(("%.6g %.6g => EXPONENT OF ZERO\n", d1, d2)); @@ -4175,261 +4857,345 @@ TclExecuteByteCode(interp, codePtr) } NEXT_INST_F(1, 1, 0); } - } - - case INST_UPLUS: { - /* - * Operand must be numeric. - */ - - double d; - Tcl_ObjType *tPtr; - Tcl_Obj *valuePtr; - - valuePtr = *tosPtr; - tPtr = valuePtr->typePtr; - if (IS_INTEGER_TYPE(tPtr) - || ((tPtr == &tclDoubleType) && (valuePtr->bytes == NULL))) { - /* - * We already have a numeric internal rep, either some kind of - * integer, or a "pure" double. (Need "pure" so that we know the - * string rep of the double would not prefer to be interpreted as - * an integer.) - */ - } else { - /* - * Otherwise, we need to generate a numeric internal rep. from - * the string rep. - */ - int length; - long i; /* Set but never used, needed in GET_WIDE_OR_INT */ - Tcl_WideInt w; - char *s = Tcl_GetStringFromObj(valuePtr, &length); - - if (TclLooksLikeInt(s, length)) { - GET_WIDE_OR_INT(result, valuePtr, i, w); - } else { - result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL, valuePtr, &d); - } - if (result != TCL_OK) { - TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", - s, (tPtr? tPtr->name : "null"))); - IllegalExprOperandType(interp, pc, valuePtr); - goto checkForCatch; +#else + value2Ptr = *tosPtr; + valuePtr = *(tosPtr - 1); + result = Tcl_GetDoubleFromObj(NULL, valuePtr, &d1); + if (result != TCL_OK) { +#ifdef ACCEPT_NAN + if (valuePtr->typePtr == &tclDoubleType) { + /* NaN first argument -> result is also NaN */ + result = TCL_OK; + NEXT_INST_F(1, 1, 0); } - tPtr = valuePtr->typePtr; +#endif + TRACE(("%.20s %.20s => ILLEGAL 1st TYPE %s\n", + O2S(value2Ptr), O2S(valuePtr), + (valuePtr->typePtr? valuePtr->typePtr->name: "null"))); + IllegalExprOperandType(interp, pc, valuePtr); + goto checkForCatch; } - - /* - * Ensure that the operand's string rep is the same as the formatted - * version of its internal rep. This makes sure that "expr +000123" - * yields "83", not "000123". We implement this by _discarding_ the - * string rep since we know it will be regenerated, if needed later, - * by formatting the internal rep's value. - */ - - if (Tcl_IsShared(valuePtr)) { - if (tPtr == &tclIntType) { - TclNewLongObj(objResultPtr, valuePtr->internalRep.longValue); - } else if (tPtr == &tclWideIntType) { - Tcl_WideInt w; - - TclGetWide(w,valuePtr); - TclNewWideIntObj(objResultPtr, w); - } else { - TclNewDoubleObj(objResultPtr, valuePtr->internalRep.doubleValue); + result = Tcl_GetDoubleFromObj(NULL, value2Ptr, &d2); + if (result != TCL_OK) { +#ifdef ACCEPT_NAN + if (value2Ptr->typePtr == &tclDoubleType) { + /* NaN second argument -> result is also NaN */ + objResultPtr = value2Ptr; + result = TCL_OK; + NEXT_INST_F(1, 2, 1); } - TRACE_WITH_OBJ(("%s => ", O2S(objResultPtr)), objResultPtr); - NEXT_INST_F(1, 1, 1); - } else { - TclInvalidateStringRep(valuePtr); - TRACE_WITH_OBJ(("%s => ", O2S(valuePtr)), valuePtr); - NEXT_INST_F(1, 0, 0); +#endif + TRACE(("%.20s %.20s => ILLEGAL 2nd TYPE %s\n", + O2S(value2Ptr), O2S(valuePtr), + (value2Ptr->typePtr? value2Ptr->typePtr->name: "null"))); + IllegalExprOperandType(interp, pc, value2Ptr); + goto checkForCatch; } - } - - case INST_UMINUS: - case INST_LNOT: { - /* - * The operand must be numeric or a boolean string as accepted by - * Tcl_GetBooleanFromObj(). If the operand object is unshared modify - * it directly, otherwise create a copy to modify: this is "copy on - * write". Free any old string representation since it is now - * invalid. - */ - - double d; - int boolvar; - long i; - int negate_value = 1; - Tcl_WideInt w; - Tcl_ObjType *tPtr; - Tcl_Obj *valuePtr; - - valuePtr = *tosPtr; - tPtr = valuePtr->typePtr; - if (IS_INTEGER_TYPE(tPtr) - || ((tPtr == &tclDoubleType) && (valuePtr->bytes == NULL))) { - /* - * We already have a numeric internal rep, either some kind of - * integer, or a "pure" double. (Need "pure" so that we know the - * string rep of the double would not prefer to be interpreted as - * an integer.) - */ - } else { + if (valuePtr->typePtr == &tclDoubleType + || value2Ptr->typePtr == &tclDoubleType) { + /* At least one of the values is floating-point, so perform + * floating point calculations */ + switch (*pc) { + case INST_EXPON: + if (d1==0.0 && d2<0.0) { + TRACE(("%.6g %.6g => EXPONENT OF ZERO\n", d1, d2)); + goto exponOfZero; + } + dResult = pow(d1, d2); + break; + case INST_MOD: + if (valuePtr->typePtr == &tclDoubleType) { + TRACE(("%.20s %.20s => ILLEGAL 1st TYPE %s\n", + O2S(value2Ptr), O2S(valuePtr), (valuePtr->typePtr? + valuePtr->typePtr->name: "null"))); + IllegalExprOperandType(interp, pc, valuePtr); + } else { + TRACE(("%.20s %.20s => ILLEGAL 2nd TYPE %s\n", + O2S(value2Ptr), O2S(valuePtr), (value2Ptr->typePtr? + value2Ptr->typePtr->name: "null"))); + IllegalExprOperandType(interp, pc, value2Ptr); + } + result = TCL_ERROR; + goto checkForCatch; + } +#ifndef ACCEPT_NAN /* - * Otherwise, we need to generate a numeric internal rep. from - * the string rep. + * Check now for IEEE floating-point error. */ - int length; - char *s = Tcl_GetStringFromObj(valuePtr, &length); - if (TclLooksLikeInt(s, length)) { - GET_WIDE_OR_INT(result, valuePtr, i, w); - - /* - * An integer was parsed. If parsing a literal that is the - * smallest long value, then it would have been promoted to a - * wide since it would not fit in a long type without the - * leading '-'. Convert back to the smallest possible long. - */ - if ((result == TCL_OK) && - (*pc == INST_UMINUS) && - (valuePtr->typePtr == &tclWideIntType) && - (w == -Tcl_LongAsWide(LONG_MIN))) { - valuePtr->typePtr = &tclIntType; - valuePtr->internalRep.longValue = LONG_MIN; - negate_value = 0; - } - } else { - result = Tcl_GetDoubleFromObj(NULL, valuePtr, &d); - } - if (result == TCL_ERROR && *pc == INST_LNOT) { - result = Tcl_GetBooleanFromObj(NULL, valuePtr, &boolvar); - i = (long)boolvar; /* i is long, not int! */ - } - if (result != TCL_OK) { - TRACE(("\"%.20s\" => ILLEGAL TYPE %s\n", s, - (tPtr? tPtr->name : "null"))); - IllegalExprOperandType(interp, pc, valuePtr); + if (TclIsNaN(dResult)) { + TRACE(("%.20s %.20s => IEEE FLOATING PT ERROR\n", + O2S(valuePtr), O2S(value2Ptr))); + TclExprFloatError(interp, dResult); + result = TCL_ERROR; goto checkForCatch; } - tPtr = valuePtr->typePtr; - } - - if (*pc == INST_UMINUS) { +#endif if (Tcl_IsShared(valuePtr)) { - /* - * Create a new object. - */ - if (tPtr == &tclIntType) { - i = valuePtr->internalRep.longValue; - if (negate_value) { - i = -i; + TclNewDoubleObj(objResultPtr, dResult); + NEXT_INST_F(1, 2, 1); + } + TclSetDoubleObj(valuePtr, dResult); + NEXT_INST_F(1, 1, 0); + } else { + /* Both values are some kind of integer */ + /* TODO: optimize use of narrower native integers */ + mp_int big1, big2, bigResult, bigRemainder; + Tcl_GetBignumFromObj(NULL, valuePtr, &big1); + Tcl_GetBignumFromObj(NULL, value2Ptr, &big2); + mp_init(&bigResult); + switch (*pc) { + case INST_MOD: + if (mp_iszero(&big2)) { + TRACE(("%s %s => DIVIDE BY ZERO\n", O2S(valuePtr), + O2S(value2Ptr))); + mp_clear(&big1); + mp_clear(&big2); + goto divideByZero; + } + mp_init(&bigRemainder); + mp_div(&big1, &big2, &bigResult, &bigRemainder); + if (!mp_iszero(&bigRemainder) + && (bigRemainder.sign != big2.sign)) { + /* Convert to Tcl's integer division rules */ + mp_sub_d(&bigResult, 1, &bigResult); + mp_add(&bigRemainder, &big2, &bigRemainder); + } + if (*pc == INST_MOD) { + mp_copy(&bigRemainder, &bigResult); + } + mp_clear(&bigRemainder); + break; + case INST_EXPON: + if (mp_iszero(&big2)) { + /* Anything to the zero power is 1 */ + mp_clear(&big1); + mp_clear(&big2); + objResultPtr = eePtr->constants[1]; + NEXT_INST_F(1, 2, 1); + } + if (mp_iszero(&big1)) { + if (mp_cmp_d(&big2, 0) == MP_LT) { + TRACE(("%s %s => EXPONENT OF ZERO\n", O2S(valuePtr), + O2S(value2Ptr))); + mp_clear(&big1); + mp_clear(&big2); + goto exponOfZero; } - TclNewLongObj(objResultPtr, i); - TRACE_WITH_OBJ(("%ld => ", i), objResultPtr); - } else if (tPtr == &tclWideIntType) { - TclGetWide(w,valuePtr); - TclNewWideIntObj(objResultPtr, -w); - TRACE_WITH_OBJ((LLD" => ", w), objResultPtr); - } else { - d = valuePtr->internalRep.doubleValue; - TclNewDoubleObj(objResultPtr, -d); - TRACE_WITH_OBJ(("%.6g => ", d), objResultPtr); + mp_clear(&big1); + mp_clear(&big2); + objResultPtr = eePtr->constants[0]; + NEXT_INST_F(1, 2, 1); } - NEXT_INST_F(1, 1, 1); - } else { - /* - * valuePtr is unshared. Modify it directly. - */ - if (tPtr == &tclIntType) { - i = valuePtr->internalRep.longValue; - if (negate_value) { - i = -i; + if (mp_cmp_d(&big2, 0) == MP_LT) { + switch (mp_cmp_d(&big1, 1)) { + case MP_GT: + objResultPtr = eePtr->constants[0]; + break; + case MP_EQ: + objResultPtr = eePtr->constants[1]; + break; + case MP_LT: + mp_add_d(&big1, 1, &big1); + if (mp_cmp_d(&big1, 0) == MP_LT) { + objResultPtr = eePtr->constants[0]; + break; + } + mp_mod_2d(&big2, 1, &big2); + if (mp_iszero(&big2)) { + objResultPtr = eePtr->constants[1]; + } else { + TclNewIntObj(objResultPtr, -1); + } } - TclSetLongObj(valuePtr, i); - TRACE_WITH_OBJ(("%ld => ", i), valuePtr); - } else if (tPtr == &tclWideIntType) { - TclGetWide(w,valuePtr); - TclSetWideIntObj(valuePtr, -w); - TRACE_WITH_OBJ((LLD" => ", w), valuePtr); - } else { - d = valuePtr->internalRep.doubleValue; - TclSetDoubleObj(valuePtr, -d); - TRACE_WITH_OBJ(("%.6g => ", d), valuePtr); + mp_clear(&big1); + mp_clear(&big2); + NEXT_INST_F(1, 2, 1); } - NEXT_INST_F(1, 0, 0); + if (big2.used > 1) { + Tcl_SetObjResult(interp, + Tcl_NewStringObj("exponent too large", -1)); + mp_clear(&big1); + mp_clear(&big2); + goto checkForCatch; + } + mp_expt_d(&big1, big2.dp[0], &bigResult); + break; } - } else { /* *pc == INST_UMINUS */ - if ((tPtr == &tclIntType) || (tPtr == &tclBooleanType)) { - i = !valuePtr->internalRep.longValue; - TRACE_WITH_OBJ(("%ld => ", i), objResultPtr); - } else if (tPtr == &tclWideIntType) { - TclGetWide(w,valuePtr); - i = (w == W0); - TRACE_WITH_OBJ((LLD" => ", w), objResultPtr); - } else { - i = (valuePtr->internalRep.doubleValue == 0.0); - TRACE_WITH_OBJ(("%.6g => ", d), objResultPtr); + mp_clear(&big1); + mp_clear(&big2); + TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); + if (Tcl_IsShared(valuePtr)) { + objResultPtr = Tcl_NewBignumObj(&bigResult); + TRACE(("%s\n", O2S(objResultPtr))); + NEXT_INST_F(1, 2, 1); } - objResultPtr = eePtr->constants[i]; - NEXT_INST_F(1, 1, 1); + Tcl_SetBignumObj(valuePtr, &bigResult); + TRACE(("%s\n", O2S(valuePtr))); + NEXT_INST_F(1, 1, 0); } +#endif } - case INST_BITNOT: { - /* - * The operand must be an integer. If the operand object is unshared - * modify it directly, otherwise modify a copy. Free any old string - * representation since it is now invalid. - */ + case INST_LNOT: { + int b; + Tcl_Obj *valuePtr = *tosPtr; - Tcl_ObjType *tPtr; - Tcl_Obj *valuePtr; - Tcl_WideInt w; - long i; + /* TODO - check claim that taking address of b harms performance */ + /* TODO - consider optimization search for eePtr->constants */ + result = TclGetBooleanFromObj(NULL, valuePtr, &b); + if (result != TCL_OK) { + TRACE(("\"%.20s\" => ILLEGAL TYPE %s\n", O2S(valuePtr), + (valuePtr->typePtr? valuePtr->typePtr->name : "null"))); + IllegalExprOperandType(interp, pc, valuePtr); + goto checkForCatch; + } + /* TODO: Consider peephole opt. */ + objResultPtr = eePtr->constants[!b]; + NEXT_INST_F(1, 1, 1); + } - valuePtr = *tosPtr; - tPtr = valuePtr->typePtr; - if (!IS_INTEGER_TYPE(tPtr)) { - REQUIRE_WIDE_OR_INT(result, valuePtr, i, w); - if (result != TCL_OK) { /* try to convert to double */ - TRACE(("\"%.20s\" => ILLEGAL TYPE %s\n", - O2S(valuePtr), (tPtr? tPtr->name : "null"))); - IllegalExprOperandType(interp, pc, valuePtr); - goto checkForCatch; + case INST_BITNOT: { + mp_int big; + ClientData ptr; + int type; + Tcl_Obj *valuePtr = *tosPtr; + + result = GetNumberFromObj(NULL, valuePtr, &ptr, &type); + if ((result != TCL_OK) + || (type == TCL_NUMBER_NAN) || (type == TCL_NUMBER_DOUBLE)) { + /* ... ~$NonInteger => raise an error */ + result = TCL_ERROR; + TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(valuePtr), + (valuePtr->typePtr? valuePtr->typePtr->name : "null"))); + IllegalExprOperandType(interp, pc, valuePtr); + goto checkForCatch; + } + if (type == TCL_NUMBER_LONG) { + long l = *((CONST long *)ptr); + if (Tcl_IsShared(valuePtr)) { + TclNewLongObj(objResultPtr, ~l); + NEXT_INST_F(1, 1, 1); } + TclSetLongObj(valuePtr, ~l); + NEXT_INST_F(1, 0, 0); } - - if (valuePtr->typePtr == &tclWideIntType) { - TclGetWide(w,valuePtr); +#ifndef NO_WIDE_TYPE + if (type == TCL_NUMBER_LONG) { + Tcl_WideInt w = *((CONST Tcl_WideInt *)ptr); if (Tcl_IsShared(valuePtr)) { - TclNewWideIntObj(objResultPtr, ~w); - TRACE(("0x%llx => (%llu)\n", w, ~w)); + objResultPtr = Tcl_NewWideIntObj(~w); NEXT_INST_F(1, 1, 1); - } else { - /* - * valuePtr is unshared. Modify it directly. - */ - TclSetWideIntObj(valuePtr, ~w); - TRACE(("0x%llx => (%llu)\n", w, ~w)); - NEXT_INST_F(1, 0, 0); } + Tcl_SetWideIntObj(valuePtr, ~w); + NEXT_INST_F(1, 0, 0); + } +#endif + if (Tcl_IsShared(valuePtr)) { + Tcl_GetBignumFromObj(NULL, valuePtr, &big); } else { - i = valuePtr->internalRep.longValue; + Tcl_GetBignumAndClearObj(NULL, valuePtr, &big); + } + /* ~a = - a - 1 */ + mp_neg(&big, &big); + mp_sub_d(&big, 1, &big); + if (Tcl_IsShared(valuePtr)) { + objResultPtr = Tcl_NewBignumObj(&big); + NEXT_INST_F(1, 1, 1); + } + Tcl_SetBignumObj(valuePtr, &big); + NEXT_INST_F(1, 0, 0); + } + + case INST_UMINUS: { + ClientData ptr; + int type; + Tcl_Obj *valuePtr = *tosPtr; + + result = GetNumberFromObj(NULL, valuePtr, &ptr, &type); + if ((result != TCL_OK) +#ifndef ACCEPT_NAN + || (type == TCL_NUMBER_NAN) +#endif + ) { + result = TCL_ERROR; + TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(valuePtr), + (valuePtr->typePtr? valuePtr->typePtr->name : "null"))); + IllegalExprOperandType(interp, pc, valuePtr); + goto checkForCatch; + } + switch (type) { + case TCL_NUMBER_DOUBLE: { + double d; if (Tcl_IsShared(valuePtr)) { - TclNewLongObj(objResultPtr, ~i); - TRACE(("0x%lx => (%lu)\n", i, ~i)); + TclNewDoubleObj(objResultPtr, -(*((CONST double *)ptr))); NEXT_INST_F(1, 1, 1); + } + d = *((CONST double *)ptr); + TclSetDoubleObj(valuePtr, -d); + NEXT_INST_F(1, 0, 0); + } + case TCL_NUMBER_LONG: { + long l = *((CONST long *)ptr); + if (l != LONG_MIN) { + if (Tcl_IsShared(valuePtr)) { + TclNewLongObj(objResultPtr, -l); + NEXT_INST_F(1, 1, 1); + } + TclSetLongObj(valuePtr, -l); + NEXT_INST_F(1, 0, 0); + } + /* FALLTHROUGH */ + } +#ifndef NO_WIDE_TYPE + case TCL_NUMBER_WIDE: { + Tcl_WideInt w; + if (type == TCL_NUMBER_LONG) { + w = (Tcl_WideInt)(*((CONST long *)ptr)); } else { - /* - * valuePtr is unshared. Modify it directly. - */ - TclSetLongObj(valuePtr, ~i); - TRACE(("0x%lx => (%lu)\n", i, ~i)); + w = *((CONST Tcl_WideInt *)ptr); + } + if (w != LLONG_MIN) { + if (Tcl_IsShared(valuePtr)) { + objResultPtr = Tcl_NewWideIntObj(-w); + NEXT_INST_F(1, 1, 1); + } + Tcl_SetWideIntObj(valuePtr, -w); NEXT_INST_F(1, 0, 0); } + /* FALLTHROUGH */ + } +#endif + case TCL_NUMBER_BIG: { + mp_int big; + switch (type) { +#ifdef NO_WIDE_TYPE + case TCL_NUMBER_LONG: + TclBNInitBignumFromLong(&big, *((CONST long *)ptr)); + break; +#else + case TCL_NUMBER_WIDE: + TclBNInitBignumFromWideInt(&big, *((CONST Tcl_WideInt*)ptr)); + break; +#endif + case TCL_NUMBER_BIG: + if (Tcl_IsShared(valuePtr)) { + Tcl_GetBignumFromObj(NULL, valuePtr, &big); + } else { + Tcl_GetBignumAndClearObj(NULL, valuePtr, &big); + } + } + mp_neg(&big, &big); + if (Tcl_IsShared(valuePtr)) { + objResultPtr = Tcl_NewBignumObj(&big); + NEXT_INST_F(1, 1, 1); + } + Tcl_SetBignumObj(valuePtr, &big); + NEXT_INST_F(1, 0, 0); + } + case TCL_NUMBER_NAN: + /* -NaN => NaN */ + NEXT_INST_F(1, 0, 0); } } @@ -4441,109 +5207,78 @@ TclExecuteByteCode(interp, codePtr) Tcl_Panic("TclExecuteByteCode: obsolete INST_CALL_FUNC1 found"); } + case INST_UPLUS: case INST_TRY_CVT_TO_NUMERIC: { /* - * Try to convert the topmost stack object to an int or double object. - * This is done in order to support Tcl's policy of interpreting - * operands if at all possible as first integers, else floating-point - * numbers. + * Try to convert the topmost stack object to numeric object. + * This is done in order to support [expr]'s policy of interpreting + * operands if at all possible as numbers first, then strings. */ - double d; - char *s; - Tcl_ObjType *tPtr; - int converted, needNew, length; - Tcl_Obj *valuePtr; - long i; - Tcl_WideInt w; + ClientData ptr; + int type; + Tcl_Obj *valuePtr = *tosPtr; - valuePtr = *tosPtr; - tPtr = valuePtr->typePtr; - converted = 0; - if (IS_INTEGER_TYPE(tPtr) - || ((tPtr == &tclDoubleType) && (valuePtr->bytes == NULL))) { - /* - * We already have a numeric internal rep, either some kind of - * integer, or a "pure" double. (Need "pure" so that we know the - * string rep of the double would not prefer to be interpreted as - * an integer.) - */ - } else { - /* - * Otherwise, we need to generate a numeric internal rep. from - * the string rep. - */ - s = Tcl_GetStringFromObj(valuePtr, &length); - if (TclLooksLikeInt(s, length)) { - GET_WIDE_OR_INT(result, valuePtr, i, w); + if (GetNumberFromObj(NULL, valuePtr, &ptr, &type) != TCL_OK) { + if (*pc == INST_UPLUS) { + /* ... +$NonNumeric => raise an error */ + result = TCL_ERROR; + TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(valuePtr), + (valuePtr->typePtr? valuePtr->typePtr->name : "null"))); + IllegalExprOperandType(interp, pc, valuePtr); + goto checkForCatch; } else { - result = Tcl_GetDoubleFromObj(NULL, valuePtr, &d); + /* ... TryConvertToNumeric($NonNumeric) is acceptable */ + TRACE(("\"%.20s\" => not numeric\n", O2S(valuePtr))); + NEXT_INST_F(1, 0, 0); } - if (result == TCL_OK) { - converted = 1; + } +#ifndef ACCEPT_NAN + if (type == TCL_NUMBER_NAN) { + result = TCL_ERROR; + if (*pc == INST_UPLUS) { + /* ... +$NonNumeric => raise an error */ + TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(valuePtr), + (valuePtr->typePtr? valuePtr->typePtr->name : "null"))); + IllegalExprOperandType(interp, pc, valuePtr); + } else { + /* Numeric conversion of NaN -> error */ + TRACE(("\"%.20s\" => IEEE FLOATING PT ERROR\n", + O2S(objResultPtr))); + TclExprFloatError(interp, *((CONST double *)ptr)); } - result = TCL_OK; /* reset the result variable */ - tPtr = valuePtr->typePtr; + goto checkForCatch; } +#endif /* - * Ensure that the topmost stack object, if numeric, has a string rep - * the same as the formatted version of its internal rep. This is - * used, e.g., to make sure that "expr {0001}" yields "1", not - * "0001". We implement this by _discarding_ the string rep since we - * know it will be regenerated, if needed later, by formatting the - * internal rep's value. Also check if there has been an IEEE floating - * point error. + * Ensure that the numeric value has a string rep the same as + * the formatted version of its internal rep. This is used, e.g., + * to make sure that "expr {0001}" yields "1", not "0001". + * We implement this by _discarding_ the string rep since we + * know it will be regenerated, if needed later, by formatting + * the internal rep's value. */ - - objResultPtr = valuePtr; - needNew = 0; - if (IS_NUMERIC_TYPE(tPtr)) { - if (Tcl_IsShared(valuePtr)) { - if (valuePtr->bytes != NULL) { - /* - * We only need to make a copy of the object when it - * already had a string rep - */ - needNew = 1; - if (tPtr == &tclIntType) { - i = valuePtr->internalRep.longValue; - TclNewLongObj(objResultPtr, i); - } else if (tPtr == &tclWideIntType) { - TclGetWide(w,valuePtr); - TclNewWideIntObj(objResultPtr, w); - } else { - d = valuePtr->internalRep.doubleValue; - TclNewDoubleObj(objResultPtr, d); - } - tPtr = objResultPtr->typePtr; - } - } else { - Tcl_InvalidateStringRep(valuePtr); - } - - if (tPtr == &tclDoubleType) { - d = objResultPtr->internalRep.doubleValue; - if (IS_NAN(d)) { - TRACE(("\"%.20s\" => IEEE FLOATING PT ERROR\n", - O2S(objResultPtr))); - TclExprFloatError(interp, d); - result = TCL_ERROR; - goto checkForCatch; - } - } - converted = converted; /* lint, converted not used. */ - TRACE(("\"%.20s\" => numeric, %s, %s\n", O2S(valuePtr), - (converted? "converted" : "not converted"), - (needNew? "new Tcl_Obj" : "same Tcl_Obj"))); - } else { - TRACE(("\"%.20s\" => not numeric\n", O2S(valuePtr))); + if (valuePtr->bytes == NULL) { + TRACE(("\"%.20s\" => numeric, same Tcl_Obj\n", O2S(valuePtr))); + NEXT_INST_F(1, 0, 0); } - if (needNew) { + if (Tcl_IsShared(valuePtr)) { + /* + * Here we do some surgery within the Tcl_Obj internals. + * We want to copy the intrep, but not the string, so we + * temporarily hide the string so we do not copy it. + */ + char *savedString = valuePtr->bytes; + valuePtr->bytes = NULL; + objResultPtr = Tcl_DuplicateObj(valuePtr); + valuePtr->bytes = savedString; + TRACE(("\"%.20s\" => numeric, new Tcl_Obj\n", O2S(valuePtr))); NEXT_INST_F(1, 1, 1); - } else { - NEXT_INST_F(1, 0, 0); } + TclInvalidateStringRep(valuePtr); + TRACE(("\"%.20s\" => numeric, same Tcl_Obj\n", O2S(valuePtr))); + NEXT_INST_F(1, 0, 0); } case INST_BREAK: @@ -4779,7 +5514,7 @@ TclExecuteByteCode(interp, codePtr) NEXT_INST_F(1, 0, -1); case INST_PUSH_RETURN_CODE: - TclNewLongObj(objResultPtr, result); + TclNewIntObj(objResultPtr, result); TRACE(("=> %u\n", result)); NEXT_INST_F(1, 0, 1); @@ -4788,6 +5523,7 @@ TclExecuteByteCode(interp, codePtr) TRACE_WITH_OBJ(("=> "), objResultPtr); NEXT_INST_F(1, 0, 1); +/* TODO: normalize "valPtr" to "valuePtr" */ { int opnd, opnd2, allocateDict; Tcl_Obj *dictPtr, *valPtr; @@ -4874,34 +5610,19 @@ TclExecuteByteCode(interp, codePtr) break; } if (valPtr == NULL) { - Tcl_DictObjPut(NULL, dictPtr, *tosPtr, Tcl_NewLongObj(opnd)); - } else if (valPtr->typePtr == &tclWideIntType) { - Tcl_WideInt wvalue; - - Tcl_GetWideIntFromObj(NULL, valPtr, &wvalue); - Tcl_DictObjPut(NULL, dictPtr, *tosPtr, - Tcl_NewWideIntObj(wvalue + opnd)); - } else if (valPtr->typePtr == &tclIntType) { - long value; - - Tcl_GetLongFromObj(NULL, valPtr, &value); - Tcl_DictObjPut(NULL, dictPtr, *tosPtr, - Tcl_NewLongObj(value + opnd)); + Tcl_DictObjPut(NULL, dictPtr, *tosPtr, Tcl_NewIntObj(opnd)); } else { - long value = 0; /* stop compiler warning */ - Tcl_WideInt wvalue; - - REQUIRE_WIDE_OR_INT(result, valPtr, value, wvalue); - if (result != TCL_OK) { - break; + Tcl_Obj *incrPtr = Tcl_NewIntObj(opnd); + Tcl_IncrRefCount(incrPtr); + if (Tcl_IsShared(valPtr)) { + valPtr = Tcl_DuplicateObj(valPtr); + Tcl_DictObjPut(NULL, dictPtr, *tosPtr, valPtr); } - if (valPtr->typePtr == &tclWideIntType) { - Tcl_DictObjPut(NULL, dictPtr, *tosPtr, - Tcl_NewWideIntObj(wvalue + opnd)); - } else { - Tcl_DictObjPut(NULL, dictPtr, *tosPtr, - Tcl_NewLongObj(value + opnd)); + result = TclIncrObj(interp, valPtr, incrPtr); + if (result == TCL_OK) { + Tcl_InvalidateStringRep(dictPtr); } + Tcl_DecrRefCount(incrPtr); } break; case INST_DICT_UNSET: @@ -5134,7 +5855,8 @@ TclExecuteByteCode(interp, codePtr) } TRACE_APPEND(("\"%.30s\" \"%.30s\" %d", O2S(*(tosPtr-1)), O2S(*tosPtr), done)); - objResultPtr = Tcl_NewBooleanObj(done); + objResultPtr = eePtr->constants[done]; + /*TODO: consider opt like INST_FOREACH_STEP4 */ NEXT_INST_F(5, 0, 1); case INST_DICT_DONE: @@ -5722,116 +6444,38 @@ IllegalExprOperandType(interp, pc, opndPtr) Tcl_Obj *opndPtr; /* Points to the operand holding the value * with the illegal type. */ { - unsigned char opCode = *pc; - CONST char *operator = operatorStrings[opCode - INST_LOR]; - if (opCode == INST_EXPON) { + ClientData ptr; + int type; + unsigned char opcode = *pc; + CONST char *description, *operator = operatorStrings[opcode - INST_LOR]; + Tcl_Obj *msg = Tcl_NewObj(); + + if (opcode == INST_EXPON) { operator = "**"; } - Tcl_SetObjResult(interp, Tcl_NewObj()); - if ((opndPtr->bytes == NULL) || (opndPtr->length == 0)) { - Tcl_AppendResult(interp, "can't use empty string as operand of \"", - operator, "\"", (char *) NULL); - } else { - char *msg = "non-numeric string"; - char *s, *p; - int length; - int looksLikeInt = 0; - - s = Tcl_GetStringFromObj(opndPtr, &length); - p = s; - /* - * strtod() isn't at all consistent about detecting Inf and NaN - * between platforms. - */ - if (length == 3) { - if ((s[0]=='n' || s[0]=='N') && (s[1]=='a' || s[1]=='A') && - (s[2]=='n' || s[2]=='N')) { - msg = "non-numeric floating-point value"; - goto makeErrorMessage; - } - if ((s[0]=='i' || s[0]=='I') && (s[1]=='n' || s[1]=='N') && - (s[2]=='f' || s[2]=='F')) { - msg = "infinite floating-point value"; - goto makeErrorMessage; - } - } - - /* - * We cannot use TclLooksLikeInt here because it passes strings like - * "10;" [Bug 587140]. We'll accept as "looking like ints" for the - * present purposes any string that looks formally like a - * (decimal|octal|hex) integer. - */ - - while (length && isspace(UCHAR(*p))) { - length--; - p++; - } - if (length && ((*p == '+') || (*p == '-'))) { - length--; - p++; - } - if (length) { - if ((*p == '0') && ((*(p+1) == 'x') || (*(p+1) == 'X'))) { - p += 2; - length -= 2; - looksLikeInt = ((length > 0) && isxdigit(UCHAR(*p))); - if (looksLikeInt) { - length--; - p++; - while (length && isxdigit(UCHAR(*p))) { - length--; - p++; - } - } - } else { - looksLikeInt = (length && isdigit(UCHAR(*p))); - if (looksLikeInt) { - length--; - p++; - while (length && isdigit(UCHAR(*p))) { - length--; - p++; - } - } - } - while (length && isspace(UCHAR(*p))) { - length--; - p++; - } - looksLikeInt = !length; - } - if (looksLikeInt) { - /* - * If something that looks like an integer could not be converted, - * then it *must* be a bad octal or too large to represent [Bug - * 542588]. - */ - - if (TclCheckBadOctal(NULL, s)) { - msg = "invalid octal number"; - } else { - msg = "integer value too large to represent"; - Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", - "integer value too large to represent", (char *) NULL); - } + if (GetNumberFromObj(NULL, opndPtr, &ptr, &type) != TCL_OK) { + int numBytes; + CONST char *bytes = Tcl_GetStringFromObj(opndPtr, &numBytes); + if (numBytes == 0) { + description = "empty string"; + } else if (TclCheckBadOctal(NULL, bytes)) { + description = "invalid octal number"; } else { - /* - * See if the operand can be interpreted as a double in order to - * improve the error message. - */ - - double d; - - if (Tcl_GetDouble((Tcl_Interp *) NULL, s, &d) == TCL_OK) { - msg = "floating-point value"; - } + description = "non-numeric string"; } - makeErrorMessage: - Tcl_AppendResult(interp, "can't use ", msg, " as operand of \"", - operator, "\"", (char *) NULL); + } else if (type == TCL_NUMBER_NAN) { + description = "non-numeric floating-point value"; + } else if (type == TCL_NUMBER_DOUBLE) { + description = "floating-point value"; + } else { + /* TODO: No caller needs this. Eliminate? */ + description = "(big) integer"; } + + TclObjPrintf(NULL, msg, "can't use %s as operand of \"%s\"", + description, operator); + Tcl_SetObjResult(interp, msg); } /* @@ -6054,6 +6698,7 @@ GetOpcodeName(pc) } #endif /* TCL_COMPILE_DEBUG */ + /* *---------------------------------------------------------------------- * @@ -6079,11 +6724,11 @@ TclExprFloatError(interp, value) { CONST char *s; - if ((errno == EDOM) || IS_NAN(value)) { + if ((errno == EDOM) || TclIsNaN(value)) { s = "domain error: argument not in valid range"; Tcl_SetObjResult(interp, Tcl_NewStringObj(s, -1)); Tcl_SetErrorCode(interp, "ARITH", "DOMAIN", s, (char *) NULL); - } else if ((errno == ERANGE) || IS_INF(value)) { + } else if ((errno == ERANGE) || TclIsInfinite(value)) { if (value == 0.0) { s = "floating-point value too small to represent"; Tcl_SetObjResult(interp, Tcl_NewStringObj(s, -1)); @@ -6571,6 +7216,7 @@ StringForResultCode(result) return buf; } #endif /* TCL_COMPILE_DEBUG */ +#if 0 /* *---------------------------------------------------------------------- @@ -6706,3 +7352,4 @@ ExponLong(i, i2, errExpon) } return result * i; } +#endif diff --git a/generic/tclInt.decls b/generic/tclInt.decls index 6ca9761..9a07c73 100644 --- a/generic/tclInt.decls +++ b/generic/tclInt.decls @@ -12,7 +12,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: tclInt.decls,v 1.92 2005/08/05 23:56:28 dkf Exp $ +# RCS: @(#) $Id: tclInt.decls,v 1.93 2005/10/08 14:42:45 dgp Exp $ library tcl @@ -210,10 +210,10 @@ declare 46 generic { # Tcl_Obj *TclIncrIndexedScalar(Tcl_Interp *interp, int localIndex, # long incrAmount) #} -declare 49 generic { - Tcl_Obj *TclIncrVar2(Tcl_Interp *interp, Tcl_Obj *part1Ptr, - Tcl_Obj *part2Ptr, long incrAmount, int part1NotParsed) -} +#declare 49 generic { +# Tcl_Obj *TclIncrVar2(Tcl_Interp *interp, Tcl_Obj *part1Ptr, +# Tcl_Obj *part2Ptr, long incrAmount, int part1NotParsed) +#} declare 50 generic { void TclInitCompiledLocals(Tcl_Interp *interp, CallFrame *framePtr, Namespace *nsPtr) @@ -553,9 +553,9 @@ declare 138 generic { # char *sym2, Tcl_PackageInitProc **proc1Ptr, # Tcl_PackageInitProc **proc2Ptr, ClientData *clientDataPtr) #} -declare 140 generic { - int TclLooksLikeInt(CONST char *bytes, int length) -} +#declare 140 generic { +# int TclLooksLikeInt(CONST char *bytes, int length) +#} # This is used by TclX, but should otherwise be considered private declare 141 generic { CONST84_RETURN char *TclpGetCwd(Tcl_Interp *interp, Tcl_DString *cwdPtr) @@ -709,10 +709,10 @@ declare 173 generic { # added for 8.4.3 -declare 174 generic { - Tcl_Obj *TclIncrWideVar2(Tcl_Interp *interp, Tcl_Obj *part1Ptr, - Tcl_Obj *part2Ptr, Tcl_WideInt wideIncrAmount, int part1NotParsed) -} +#declare 174 generic { +# Tcl_Obj *TclIncrWideVar2(Tcl_Interp *interp, Tcl_Obj *part1Ptr, +# Tcl_Obj *part2Ptr, Tcl_WideInt wideIncrAmount, int part1NotParsed) +#} # Factoring out of trace code diff --git a/generic/tclInt.h b/generic/tclInt.h index b810845..6dd07b0 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -12,13 +12,20 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclInt.h,v 1.252 2005/09/14 03:46:50 dgp Exp $ + * RCS: @(#) $Id: tclInt.h,v 1.253 2005/10/08 14:42:45 dgp Exp $ */ #ifndef _TCLINT #define _TCLINT /* + * Some numerics configuration options + */ + +#undef NO_WIDE_TYPE +#undef ACCEPT_NAN + +/* * Common include files needed by most of the Tcl source files are included * here, so that system-dependent personalizations for the include files only * have to be made in once place. This results in a few extra includes, but @@ -98,6 +105,14 @@ typedef int ptrdiff_t; #endif /* + * When Tcl_WideInt and long are the same type, there's no value in + * having a tclWideIntType separate from the tclIntType. + */ +#ifdef TCL_WIDE_INT_IS_LONG +#define NO_WIDE_TYPE +#endif + +/* * The following procedures allow namespaces to be customized to support * special name resolution rules for commands/variables. */ @@ -1873,6 +1888,35 @@ typedef struct ProcessGlobalValue { } ProcessGlobalValue; /* + *---------------------------------------------------------------------- + * Flags for TclParseNumber + *---------------------------------------------------------------------- + */ + +#define TCL_PARSE_DECIMAL_ONLY 1 + /* Leading zero doesn't denote octal or hex */ +#define TCL_PARSE_OCTAL_ONLY 2 + /* Parse octal even without prefix */ +#define TCL_PARSE_HEXADECIMAL_ONLY 4 + /* Parse hexadecimal even without prefix */ +#define TCL_PARSE_INTEGER_ONLY 8 + /* Disable floating point parsing */ +#define TCL_PARSE_SCAN_PREFIXES 16 + /* Use [scan] rules dealing with 0? prefixes */ + +/* + *---------------------------------------------------------------------- + * Type values TclGetNumberFromObj + *---------------------------------------------------------------------- + */ + +#define TCL_NUMBER_LONG 1 +#define TCL_NUMBER_WIDE 2 +#define TCL_NUMBER_BIG 3 +#define TCL_NUMBER_DOUBLE 4 +#define TCL_NUMBER_NAN 5 + +/* *---------------------------------------------------------------- * Variables shared among Tcl modules but not used by the outside world. *---------------------------------------------------------------- @@ -1897,6 +1941,7 @@ MODULE_SCOPE ClientData tclTimeClientData; * Variables denoting the Tcl object types defined in the core. */ +MODULE_SCOPE Tcl_ObjType tclBignumType; MODULE_SCOPE Tcl_ObjType tclBooleanType; MODULE_SCOPE Tcl_ObjType tclByteArrayType; MODULE_SCOPE Tcl_ObjType tclByteCodeType; @@ -1909,7 +1954,9 @@ MODULE_SCOPE Tcl_ObjType tclProcBodyType; MODULE_SCOPE Tcl_ObjType tclStringType; MODULE_SCOPE Tcl_ObjType tclArraySearchType; MODULE_SCOPE Tcl_ObjType tclNsNameType; +#ifndef NO_WIDE_TYPE MODULE_SCOPE Tcl_ObjType tclWideIntType; +#endif MODULE_SCOPE Tcl_ObjType tclRegexpType; /* @@ -1961,6 +2008,7 @@ MODULE_SCOPE void TclAppendObjToErrorInfo(Tcl_Interp *interp, MODULE_SCOPE int TclArraySet(Tcl_Interp *interp, Tcl_Obj *arrayNameObj, Tcl_Obj *arrayElemObj); MODULE_SCOPE double TclBignumToDouble(mp_int* bignum); +MODULE_SCOPE double TclCeil(mp_int* a); MODULE_SCOPE int TclCheckBadOctal(Tcl_Interp *interp,CONST char *value); MODULE_SCOPE int TclChanCreateObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); @@ -2000,6 +2048,7 @@ MODULE_SCOPE void TclFinalizeObjects(void); MODULE_SCOPE void TclFinalizePreserve(void); MODULE_SCOPE void TclFinalizeSynchronization(void); MODULE_SCOPE void TclFinalizeThreadData(void); +MODULE_SCOPE double TclFloor(mp_int* a); MODULE_SCOPE void TclFormatNaN(double value, char* buffer); MODULE_SCOPE int TclFormatObj(Tcl_Interp *interp, Tcl_Obj *objPtr, CONST char *format, ...); @@ -2012,6 +2061,9 @@ MODULE_SCOPE int TclGetEncodingFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_Encoding *encodingPtr); MODULE_SCOPE int TclGetNamespaceFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_Namespace **nsPtrPtr); +MODULE_SCOPE int TclGetNumberFromObj(Tcl_Interp *interp, + Tcl_Obj *objPtr, ClientData *clientDataPtr, + int *typePtr); MODULE_SCOPE int TclGetOpenModeEx(Tcl_Interp *interp, CONST char *modeString, int *seekFlagPtr, int *binaryPtr); @@ -2019,7 +2071,13 @@ MODULE_SCOPE Tcl_Obj * TclGetProcessGlobalValue(ProcessGlobalValue *pgvPtr); MODULE_SCOPE int TclGlob(Tcl_Interp *interp, char *pattern, Tcl_Obj *unquotedPrefix, int globFlags, Tcl_GlobTypeData* types); +MODULE_SCOPE int TclIncrObj(Tcl_Interp *interp, Tcl_Obj *valuePtr, + Tcl_Obj *incrPtr); +MODULE_SCOPE Tcl_Obj * TclIncrObjVar2(Tcl_Interp *interp, Tcl_Obj *part1Ptr, + Tcl_Obj *part2Ptr, Tcl_Obj *incrPtr, int flags); MODULE_SCOPE void TclInitAlloc(void); +MODULE_SCOPE int TclInitBignumFromDouble(Tcl_Interp *interp, double d, + mp_int *b); MODULE_SCOPE void TclInitDbCkalloc(void); MODULE_SCOPE void TclInitDoubleConversion(void); MODULE_SCOPE void TclInitEmbeddedConfigurationInformation( @@ -2062,9 +2120,14 @@ MODULE_SCOPE int TclParseBackslash(CONST char *src, int numBytes, int *readPtr, char *dst); MODULE_SCOPE int TclParseHex(CONST char *src, int numBytes, Tcl_UniChar *resultPtr); +MODULE_SCOPE int TclParseNumber(Tcl_Interp* interp, Tcl_Obj* objPtr, + CONST char* type, CONST char* string, + size_t length, CONST char** endPtrPtr, int flags); MODULE_SCOPE void TclParseInit(Tcl_Interp *interp, CONST char *string, int numBytes, Tcl_Parse *parsePtr); +#if 0 MODULE_SCOPE int TclParseInteger(CONST char *string, int numBytes); +#endif MODULE_SCOPE int TclParseWhiteSpace(CONST char *src, int numBytes, Tcl_Parse *parsePtr, char *typePtr); MODULE_SCOPE int TclProcessReturn(Tcl_Interp *interp, @@ -2134,10 +2197,11 @@ MODULE_SCOPE void TclRememberMutex(Tcl_Mutex *mutex); MODULE_SCOPE void TclRemoveScriptLimitCallbacks(Tcl_Interp *interp); MODULE_SCOPE void TclSetBgErrorHandler(Tcl_Interp *interp, Tcl_Obj *cmdPrefix); +MODULE_SCOPE void TclSetBignumIntRep (Tcl_Obj *objPtr, + mp_int *bignumValue); MODULE_SCOPE void TclSetProcessGlobalValue(ProcessGlobalValue *pgvPtr, Tcl_Obj *newValue, Tcl_Encoding encoding); MODULE_SCOPE VOID TclSignalExitThread(Tcl_ThreadId id, int result); -MODULE_SCOPE double TclStrToD(CONST char* string, CONST char** endPtr); MODULE_SCOPE int TclSubstTokens(Tcl_Interp *interp, Tcl_Token *tokenPtr, int count, int *tokensLeftPtr); MODULE_SCOPE void TclTransferResult(Tcl_Interp *sourceInterp, int result, @@ -2516,6 +2580,11 @@ MODULE_SCOPE Tcl_Obj * TclPtrSetVar(Tcl_Interp *interp, Var *varPtr, Var *arrayPtr, CONST char *part1, CONST char *part2, Tcl_Obj *newValuePtr, CONST int flags); +MODULE_SCOPE Tcl_Obj * TclPtrIncrObjVar (Tcl_Interp *interp, + Var *varPtr, Var *arrayPtr, CONST char *part1, + CONST char *part2, Tcl_Obj *incrPtr, + CONST int flags); +#if 0 MODULE_SCOPE Tcl_Obj * TclPtrIncrVar(Tcl_Interp *interp, Var *varPtr, Var *arrayPtr, CONST char *part1, CONST char *part2, CONST long i, CONST int flags); @@ -2523,6 +2592,7 @@ MODULE_SCOPE Tcl_Obj * TclPtrIncrWideVar(Tcl_Interp *interp, Var *varPtr, Var *arrayPtr, CONST char *part1, CONST char *part2, CONST Tcl_WideInt i, CONST int flags); +#endif MODULE_SCOPE void TclInvalidateNsPath(Namespace *nsPtr); /* @@ -2737,25 +2807,21 @@ MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr); }\ +#if 0 /* *---------------------------------------------------------------- * Macro used by the Tcl core to get a Tcl_WideInt value out of a Tcl_Obj of - * the "wideInt" type. Different implementation on different platforms - * depending whether TCL_WIDE_INT_IS_LONG. + * the "wideInt" type. *---------------------------------------------------------------- */ -#ifdef TCL_WIDE_INT_IS_LONG -# define TclGetWide(resultVar, objPtr) \ - (resultVar) = (objPtr)->internalRep.longValue -# define TclGetLongFromWide(resultVar, objPtr) \ - (resultVar) = (objPtr)->internalRep.longValue -#else +#ifndef NO_WIDE_TYPE # define TclGetWide(resultVar, objPtr) \ (resultVar) = (objPtr)->internalRep.wideValue # define TclGetLongFromWide(resultVar, objPtr) \ (resultVar) = Tcl_WideAsLong((objPtr)->internalRep.wideValue) #endif +#endif /* *---------------------------------------------------------------- @@ -2818,7 +2884,10 @@ MODULE_SCOPE void * TclBNAlloc(size_t nBytes); MODULE_SCOPE void * TclBNRealloc(void *oldBlock, size_t newNBytes); MODULE_SCOPE void TclBNFree(void *block); MODULE_SCOPE void TclBNInitBignumFromLong(mp_int *bignum, long initVal); - +MODULE_SCOPE void TclBNInitBignumFromWideInt(mp_int* bignum, + Tcl_WideInt initVal); +MODULE_SCOPE void TclBNInitBignumFromWideUInt(mp_int* bignum, + Tcl_WideUInt initVal); /* *---------------------------------------------------------------- @@ -2876,11 +2945,13 @@ MODULE_SCOPE void TclBNInitBignumFromLong(mp_int *bignum, long initVal); #define TclSetBooleanObj(objPtr, b) \ TclSetIntObj((objPtr), ((b)? 1 : 0)); +#ifndef NO_WIDE_TYPE #define TclSetWideIntObj(objPtr, w) \ TclInvalidateStringRep(objPtr);\ TclFreeIntRep(objPtr); \ (objPtr)->internalRep.wideValue = (Tcl_WideInt)(w); \ (objPtr)->typePtr = &tclWideIntType +#endif #define TclSetDoubleObj(objPtr, d) \ TclInvalidateStringRep(objPtr);\ @@ -2923,14 +2994,6 @@ MODULE_SCOPE void TclBNInitBignumFromLong(mp_int *bignum, long initVal); #define TclNewBooleanObj(objPtr, b) \ TclNewIntObj((objPtr), ((b)? 1 : 0)) -#define TclNewWideIntObj(objPtr, w) \ - TclIncrObjsAllocated(); \ - TclAllocObjStorage(objPtr); \ - (objPtr)->refCount = 0; \ - (objPtr)->bytes = NULL; \ - (objPtr)->internalRep.wideValue = (Tcl_WideInt)(w); \ - (objPtr)->typePtr = &tclWideIntType - #define TclNewDoubleObj(objPtr, d) \ TclIncrObjsAllocated(); \ TclAllocObjStorage(objPtr); \ @@ -2953,9 +3016,6 @@ MODULE_SCOPE void TclBNInitBignumFromLong(mp_int *bignum, long initVal); #define TclNewBooleanObj(objPtr, b) \ (objPtr) = Tcl_NewBooleanObj(b) -#define TclNewWideIntObj(objPtr, w)\ - (objPtr) = Tcl_NewWideIntObj(w) - #define TclNewDoubleObj(objPtr, d) \ (objPtr) = Tcl_NewDoubleObj(d) @@ -2963,6 +3023,23 @@ MODULE_SCOPE void TclBNInitBignumFromLong(mp_int *bignum, long initVal); (objPtr) = Tcl_NewStringObj((s), (len)) #endif /* TCL_MEM_DEBUG */ +/* + *---------------------------------------------------------------- + * Macros used by the Tcl core to test for some special double values. + * The ANSI C "prototypes" for these macros are: + * + * MODULE_SCOPE int TclIsInfinite _ANSI_ARGS_((double d)); + * MODULE_SCOPE int TclIsNaN _ANSI_ARGS_((double d)); + */ + +#ifdef _MSC_VER +#define TclIsInfinite(d) ( ! (_finite((d))) ) +#define TclIsNaN(d) (_isnan((d))) +#else +#define TclIsInfinite(d) ( (d) > DBL_MAX || (d) < -DBL_MAX ) +#define TclIsNaN(d) ((d) != (d)) +#endif + #include "tclPort.h" #include "tclIntDecls.h" #include "tclIntPlatDecls.h" diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h index 4d1fff3..4b19ca6 100644 --- a/generic/tclIntDecls.h +++ b/generic/tclIntDecls.h @@ -11,7 +11,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclIntDecls.h,v 1.83 2005/08/05 23:57:35 dkf Exp $ + * RCS: @(#) $Id: tclIntDecls.h,v 1.84 2005/10/08 14:42:45 dgp Exp $ */ #ifndef _TCLINTDECLS @@ -271,13 +271,7 @@ EXTERN int TclInExit _ANSI_ARGS_((void)); #endif /* Slot 47 is reserved */ /* Slot 48 is reserved */ -#ifndef TclIncrVar2_TCL_DECLARED -#define TclIncrVar2_TCL_DECLARED -/* 49 */ -EXTERN Tcl_Obj * TclIncrVar2 _ANSI_ARGS_((Tcl_Interp * interp, - Tcl_Obj * part1Ptr, Tcl_Obj * part2Ptr, - long incrAmount, int part1NotParsed)); -#endif +/* Slot 49 is reserved */ #ifndef TclInitCompiledLocals_TCL_DECLARED #define TclInitCompiledLocals_TCL_DECLARED /* 50 */ @@ -684,12 +678,7 @@ EXTERN CONST84_RETURN char * TclGetEnv _ANSI_ARGS_((CONST char * name, Tcl_DString * valuePtr)); #endif /* Slot 139 is reserved */ -#ifndef TclLooksLikeInt_TCL_DECLARED -#define TclLooksLikeInt_TCL_DECLARED -/* 140 */ -EXTERN int TclLooksLikeInt _ANSI_ARGS_((CONST char * bytes, - int length)); -#endif +/* Slot 140 is reserved */ #ifndef TclpGetCwd_TCL_DECLARED #define TclpGetCwd_TCL_DECLARED /* 141 */ @@ -872,14 +861,7 @@ EXTERN int TclUniCharMatch _ANSI_ARGS_(( CONST Tcl_UniChar * pattern, int ptnLen, int nocase)); #endif -#ifndef TclIncrWideVar2_TCL_DECLARED -#define TclIncrWideVar2_TCL_DECLARED -/* 174 */ -EXTERN Tcl_Obj * TclIncrWideVar2 _ANSI_ARGS_((Tcl_Interp * interp, - Tcl_Obj * part1Ptr, Tcl_Obj * part2Ptr, - Tcl_WideInt wideIncrAmount, - int part1NotParsed)); -#endif +/* Slot 174 is reserved */ #ifndef TclCallVarTraces_TCL_DECLARED #define TclCallVarTraces_TCL_DECLARED /* 175 */ @@ -1167,7 +1149,7 @@ typedef struct TclIntStubs { int (*tclInExit) _ANSI_ARGS_((void)); /* 46 */ void *reserved47; void *reserved48; - Tcl_Obj * (*tclIncrVar2) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * part1Ptr, Tcl_Obj * part2Ptr, long incrAmount, int part1NotParsed)); /* 49 */ + void *reserved49; void (*tclInitCompiledLocals) _ANSI_ARGS_((Tcl_Interp * interp, CallFrame * framePtr, Namespace * nsPtr)); /* 50 */ int (*tclInterpInit) _ANSI_ARGS_((Tcl_Interp * interp)); /* 51 */ void *reserved52; @@ -1263,7 +1245,7 @@ typedef struct TclIntStubs { void *reserved137; CONST84_RETURN char * (*tclGetEnv) _ANSI_ARGS_((CONST char * name, Tcl_DString * valuePtr)); /* 138 */ void *reserved139; - int (*tclLooksLikeInt) _ANSI_ARGS_((CONST char * bytes, int length)); /* 140 */ + void *reserved140; CONST84_RETURN char * (*tclpGetCwd) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_DString * cwdPtr)); /* 141 */ int (*tclSetByteCodeFromAny) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, CompileHookProc * hookProc, ClientData clientData)); /* 142 */ int (*tclAddLiteralObj) _ANSI_ARGS_((struct CompileEnv * envPtr, Tcl_Obj * objPtr, LiteralEntry ** litPtrPtr)); /* 143 */ @@ -1297,7 +1279,7 @@ typedef struct TclIntStubs { int (*tclCheckExecutionTraces) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * command, int numChars, Command * cmdPtr, int result, int traceFlags, int objc, Tcl_Obj *CONST objv[])); /* 171 */ int (*tclInThreadExit) _ANSI_ARGS_((void)); /* 172 */ int (*tclUniCharMatch) _ANSI_ARGS_((CONST Tcl_UniChar * string, int strLen, CONST Tcl_UniChar * pattern, int ptnLen, int nocase)); /* 173 */ - Tcl_Obj * (*tclIncrWideVar2) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * part1Ptr, Tcl_Obj * part2Ptr, Tcl_WideInt wideIncrAmount, int part1NotParsed)); /* 174 */ + void *reserved174; int (*tclCallVarTraces) _ANSI_ARGS_((Interp * iPtr, Var * arrayPtr, Var * varPtr, CONST char * part1, CONST char * part2, int flags, int leaveErrMsg)); /* 175 */ void (*tclCleanupVar) _ANSI_ARGS_((Var * varPtr, Var * arrayPtr)); /* 176 */ void (*tclVarErrMsg) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * part1, CONST char * part2, CONST char * operation, CONST char * reason)); /* 177 */ @@ -1520,10 +1502,7 @@ extern TclIntStubs *tclIntStubsPtr; #endif /* Slot 47 is reserved */ /* Slot 48 is reserved */ -#ifndef TclIncrVar2 -#define TclIncrVar2 \ - (tclIntStubsPtr->tclIncrVar2) /* 49 */ -#endif +/* Slot 49 is reserved */ #ifndef TclInitCompiledLocals #define TclInitCompiledLocals \ (tclIntStubsPtr->tclInitCompiledLocals) /* 50 */ @@ -1802,10 +1781,7 @@ extern TclIntStubs *tclIntStubsPtr; (tclIntStubsPtr->tclGetEnv) /* 138 */ #endif /* Slot 139 is reserved */ -#ifndef TclLooksLikeInt -#define TclLooksLikeInt \ - (tclIntStubsPtr->tclLooksLikeInt) /* 140 */ -#endif +/* Slot 140 is reserved */ #ifndef TclpGetCwd #define TclpGetCwd \ (tclIntStubsPtr->tclpGetCwd) /* 141 */ @@ -1929,10 +1905,7 @@ extern TclIntStubs *tclIntStubsPtr; #define TclUniCharMatch \ (tclIntStubsPtr->tclUniCharMatch) /* 173 */ #endif -#ifndef TclIncrWideVar2 -#define TclIncrWideVar2 \ - (tclIntStubsPtr->tclIncrWideVar2) /* 174 */ -#endif +/* Slot 174 is reserved */ #ifndef TclCallVarTraces #define TclCallVarTraces \ (tclIntStubsPtr->tclCallVarTraces) /* 175 */ diff --git a/generic/tclLink.c b/generic/tclLink.c index b16a113..2ab72ff 100644 --- a/generic/tclLink.c +++ b/generic/tclLink.c @@ -12,7 +12,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclLink.c,v 1.12 2005/09/08 10:49:19 dkf Exp $ + * RCS: @(#) $Id: tclLink.c,v 1.13 2005/10/08 14:42:45 dgp Exp $ */ #include "tclInt.h" @@ -383,9 +383,16 @@ LinkTraceProc(clientData, interp, name1, name2, flags) case TCL_LINK_DOUBLE: if (Tcl_GetDoubleFromObj(NULL, valueObj, &linkPtr->lastValue.d) != TCL_OK) { +#ifdef ACCEPT_NAN + if (valueObj->typePtr != &tclDoubleType) { +#endif Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), TCL_GLOBAL_ONLY); return "variable must have real value"; +#ifdef ACCEPT_NAN + } + linkPtr->lastValue.d = valueObj->internalRep.doubleValue; +#endif } *(double *)(linkPtr->addr) = linkPtr->lastValue.d; break; diff --git a/generic/tclObj.c b/generic/tclObj.c index 89ff127..b76055f 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -12,22 +12,14 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclObj.c,v 1.95 2005/09/05 10:25:54 dkf Exp $ + * RCS: @(#) $Id: tclObj.c,v 1.96 2005/10/08 14:42:45 dgp Exp $ */ #include "tclInt.h" #include "tommath.h" #include <float.h> -/* - * Define test for NaN - */ - -#ifdef _MSC_VER -#define IS_NAN(f) _isnan((f)) -#else -#define IS_NAN(f) ((f) != (f)) -#endif +#define BIGNUM_AUTO_NARROW 1 /* * Table of all object types. @@ -153,41 +145,46 @@ static Tcl_ThreadDataKey pendingObjDataKey; */ #define PACK_BIGNUM(bignum, objPtr) \ - do { \ - (objPtr)->internalRep.bignumValue.digits = (void*) (bignum).dp; \ - (objPtr)->internalRep.bignumValue.misc = ( \ - ((bignum).sign << 30) \ - | ((bignum).alloc << 15) \ - | ((bignum).used)); \ - } while (0) + if ((bignum).used > 0x7fff) { \ + mp_int *temp = (void *) ckalloc((unsigned) sizeof(mp_int)); \ + *temp = bignum; \ + (objPtr)->internalRep.ptrAndLongRep.ptr = (void*) temp; \ + (objPtr)->internalRep.ptrAndLongRep.value = -1; \ + } else { \ + if ((bignum).alloc > 0x7fff) { \ + mp_shrink(&(bignum)); \ + } \ + (objPtr)->internalRep.ptrAndLongRep.ptr = (void*) (bignum).dp; \ + (objPtr)->internalRep.ptrAndLongRep.value = ( ((bignum).sign << 30) \ + | ((bignum).alloc << 15) | ((bignum).used)); \ + } #define UNPACK_BIGNUM(objPtr, bignum) \ - do { \ - (bignum).dp = (mp_digit*) (objPtr)->internalRep.bignumValue.digits; \ - (bignum).sign = (objPtr)->internalRep.bignumValue.misc >> 30; \ + if ((objPtr)->internalRep.ptrAndLongRep.value == -1) { \ + (bignum) = *((mp_int *) ((objPtr)->internalRep.ptrAndLongRep.ptr)); \ + } else { \ + (bignum).dp = (mp_digit*) (objPtr)->internalRep.ptrAndLongRep.ptr; \ + (bignum).sign = (objPtr)->internalRep.ptrAndLongRep.value >> 30; \ (bignum).alloc = \ - ((objPtr)->internalRep.bignumValue.misc >> 15) & 0x7fff; \ - (bignum).used = (objPtr)->internalRep.bignumValue.misc & 0x7fff; \ - } while (0) + ((objPtr)->internalRep.ptrAndLongRep.value >> 15) & 0x7fff; \ + (bignum).used = (objPtr)->internalRep.ptrAndLongRep.value & 0x7fff; \ + } /* * Prototypes for procedures defined later in this file: */ +static int ParseBoolean _ANSI_ARGS_((Tcl_Obj *objPtr)); static int SetBooleanFromAny _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *objPtr)); static int SetDoubleFromAny _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *objPtr)); static int SetIntFromAny _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *objPtr)); -static int SetIntOrWideFromAny _ANSI_ARGS_((Tcl_Interp* interp, - Tcl_Obj *objPtr)); static void UpdateStringOfDouble _ANSI_ARGS_((Tcl_Obj *objPtr)); static void UpdateStringOfInt _ANSI_ARGS_((Tcl_Obj *objPtr)); -static int SetWideIntFromAny _ANSI_ARGS_((Tcl_Interp *interp, - Tcl_Obj *objPtr)); -#ifndef TCL_WIDE_INT_IS_LONG +#ifndef NO_WIDE_TYPE static void UpdateStringOfWideInt _ANSI_ARGS_((Tcl_Obj *objPtr)); #endif @@ -195,8 +192,8 @@ static void FreeBignum _ANSI_ARGS_((Tcl_Obj *objPtr)); static void DupBignum _ANSI_ARGS_((Tcl_Obj *objPtr, Tcl_Obj *copyPtr)); static void UpdateStringOfBignum _ANSI_ARGS_((Tcl_Obj *objPtr)); -static int SetBignumFromAny _ANSI_ARGS_((Tcl_Interp* interp, - Tcl_Obj* objPtr)); +static int GetBignumFromObj _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Obj *objPtr, int copy, mp_int *bignumValue)); /* * Prototypes for the array hash key methods. @@ -253,24 +250,24 @@ Tcl_ObjType tclIntType = { SetIntFromAny /* setFromAnyProc */ }; +#ifndef NO_WIDE_TYPE Tcl_ObjType tclWideIntType = { "wideInt", /* name */ (Tcl_FreeInternalRepProc *) NULL, /* freeIntRepProc */ (Tcl_DupInternalRepProc *) NULL, /* dupIntRepProc */ -#ifdef TCL_WIDE_INT_IS_LONG - UpdateStringOfInt, /* updateStringProc */ -#else /* !TCL_WIDE_INT_IS_LONG */ UpdateStringOfWideInt, /* updateStringProc */ -#endif /* TCL_WIDE_INT_IS_LONG */ - SetWideIntFromAny /* setFromAnyProc */ + NULL /* setFromAnyProc */ }; +#endif + + Tcl_ObjType tclBignumType = { "bignum", /* name */ FreeBignum, /* freeIntRepProc */ DupBignum, /* dupIntRepProc */ UpdateStringOfBignum, /* updateStringProc */ - SetBignumFromAny /* setFromAnyProc */ + NULL /* setFromAnyProc */ }; /* @@ -375,8 +372,6 @@ TclInitObjSubsystem() Tcl_RegisterObjType(&tclDoubleType); Tcl_RegisterObjType(&tclEndOffsetType); Tcl_RegisterObjType(&tclIntType); - Tcl_RegisterObjType(&tclWideIntType); - Tcl_RegisterObjType(&tclBignumType); Tcl_RegisterObjType(&tclStringType); Tcl_RegisterObjType(&tclDictType); Tcl_RegisterObjType(&tclByteCodeType); @@ -871,7 +866,7 @@ TclFreeObj(objPtr) typePtr->freeIntRepProc(objPtr); ObjDeletionUnlock(context); } - Tcl_InvalidateStringRep(objPtr); + TclInvalidateStringRep(objPtr); Tcl_MutexLock(&tclObjMutex); ckfree((char *) objPtr); @@ -1285,92 +1280,47 @@ Tcl_GetBooleanFromObj(interp, objPtr, boolPtr) register Tcl_Obj *objPtr; /* The object from which to get boolean. */ register int *boolPtr; /* Place to store resulting boolean. */ { - double d; - long l; - - /* - * The flow through this routine is "optimized" to avoid the generation of - * string rep. for "pure" numeric values. However, once the string rep is - * generated it's fairly inefficient at determining a string is *not* a - * valid boolean. It has to scan the string as many as four times (ruling - * out "double", "long", "wideint", and "boolean" in turn) to figure out - * that an invalid boolean value is stored in objPtr->bytes. - */ - - if (objPtr->typePtr == &tclIntType) { - *boolPtr = (int) (objPtr->internalRep.longValue != 0); - return TCL_OK; - } - if (objPtr->typePtr == &tclBooleanType) { - *boolPtr = (int) objPtr->internalRep.longValue; - return TCL_OK; - } - if (objPtr->typePtr == &tclWideIntType) { - *boolPtr = (int) (objPtr->internalRep.wideValue != 0); - return TCL_OK; - } - - /* - * Caution: Don't be tempted to check directly for the "double" - * Tcl_ObjType and then compare the intrep to 0.0. This isn't reliable - * because a "double" Tcl_ObjType can hold the NaN value. Use the API - * Tcl_GetDoubleFromObj, which does the checking for us. - */ - - /* - * The following call retrieves a numeric value without generating the - * string rep of a double. - */ - - if (Tcl_GetDoubleFromObj(NULL, objPtr, &d) == TCL_OK) { - *boolPtr = (d != 0.0); - - /* - * Tcl_GetDoubleFromObj() will succeed on the strings "0" and "1", but - * we'd rather keep those values around as a better objType for - * boolean value. Following call will shimmer appropriately. - */ - - if (objPtr->bytes != NULL) { - SetBooleanFromAny(NULL, objPtr); + do { + if (objPtr->typePtr == &tclIntType) { + *boolPtr = (objPtr->internalRep.longValue != 0); + return TCL_OK; } - return TCL_OK; - } - - /* - * Value didn't already have a numeric intrep, but perhaps we can generate - * one. Try a long value first... - */ - - if (Tcl_GetLongFromObj(NULL, objPtr, &l) == TCL_OK) { - *boolPtr = (l != 0); - return TCL_OK; - } -#ifndef TCL_WIDE_INT_IS_LONG - else { - Tcl_WideInt w; - - /* - * ...then a wide. Check in that order so that we don't promote - * anything to wide unnecessarily. - */ - - if (Tcl_GetWideIntFromObj(NULL, objPtr, &w) == TCL_OK) { - *boolPtr = (w != 0); + if (objPtr->typePtr == &tclBooleanType) { + *boolPtr = (int) objPtr->internalRep.longValue; return TCL_OK; } - } + if (objPtr->typePtr == &tclDoubleType) { + /* + * Caution: Don't be tempted to check directly for the "double" + * Tcl_ObjType and then compare the intrep to 0.0. This isn't + * reliable because a "double" Tcl_ObjType can hold the NaN value. + * Use the API Tcl_GetDoubleFromObj, which does the checking and + * sets the proper error message for us. + */ + double d; + if (Tcl_GetDoubleFromObj(interp, objPtr, &d) != TCL_OK) { + return TCL_ERROR; + } + *boolPtr = (d != 0.0); + return TCL_OK; + } + if (objPtr->typePtr == &tclBignumType) { +#ifdef BIGNUM_AUTO_NARROW + *boolPtr = 1; +#else + *boolPtr = ((objPtr->internalRep.ptrAndLongRep.value & 0x7fff)!=0); #endif - - /* - * Finally, check for the string values like "yes" and generate error - * message for non-boolean values. - */ - - if (SetBooleanFromAny(interp, objPtr) == TCL_OK) { - *boolPtr = (int) objPtr->internalRep.longValue; - return TCL_OK; - } + return TCL_OK; + } +#ifndef NO_WIDE_TYPE + if (objPtr->typePtr == &tclWideIntType) { + *boolPtr = (objPtr->internalRep.wideValue != 0); + return TCL_OK; + } +#endif + } while ((ParseBoolean(objPtr) == TCL_OK) || (TCL_OK == + TclParseNumber(interp, objPtr, "boolean value", + NULL, -1, NULL, 0))); return TCL_ERROR; } @@ -1399,9 +1349,6 @@ SetBooleanFromAny(interp, objPtr) Tcl_Interp *interp; /* Used for error reporting if not NULL. */ register Tcl_Obj *objPtr; /* The object to convert. */ { - char *str, lowerCase[6]; - int i, newBool, length; - /* * For some "pure" numeric Tcl_ObjTypes (no string rep), we can determine * whether a boolean conversion is possible without generating the string @@ -1409,9 +1356,6 @@ SetBooleanFromAny(interp, objPtr) */ if (objPtr->bytes == NULL) { - if (objPtr->typePtr == &tclDoubleType) { - goto badBoolean; - } if (objPtr->typePtr == &tclIntType) { switch (objPtr->internalRep.longValue) { case 0L: case 1L: @@ -1419,26 +1363,50 @@ SetBooleanFromAny(interp, objPtr) } goto badBoolean; } - if (objPtr->typePtr == &tclWideIntType) { - Tcl_WideInt w = objPtr->internalRep.wideValue; - if (w == 0 || w == 1) { - newBool = (int) w; - goto numericBoolean; - } else { - goto badBoolean; - } +#ifdef BIGNUM_AUTO_NARROW + if (objPtr->typePtr == &tclBignumType) { + goto badBoolean; + } +#else + /* TODO: Consider tests to discover values 0 and 1 while preserving + * pure bignum. For now, pass through string rep. */ +#endif +#ifndef NO_WIDE_TYPE + /* TODO: Consider tests to discover values 0 and 1 while preserving + * pure wide. For now, pass through string rep. */ +#endif + if (objPtr->typePtr == &tclDoubleType) { + goto badBoolean; } } - /* - * Parse the string as a boolean. We use an implementation here that - * doesn't report errors in interp if interp is NULL. - */ + if (ParseBoolean(objPtr) == TCL_OK) { + return TCL_OK; + } + + badBoolean: + if (interp != NULL) { + int length; + char *str = Tcl_GetStringFromObj(objPtr, &length); + Tcl_Obj *msg = + Tcl_NewStringObj("expected boolean value but got \"", -1); + TclAppendLimitedToObj(msg, str, length, 50, ""); + Tcl_AppendToObj(msg, "\"", -1); + Tcl_SetObjResult(interp, msg); + } + return TCL_ERROR; +} + +static int +ParseBoolean(objPtr) + register Tcl_Obj *objPtr; /* The object to parse/convert. */ +{ + int i, length, newBool; + char lowerCase[6], *str = Tcl_GetStringFromObj(objPtr, &length); - str = Tcl_GetStringFromObj(objPtr, &length); if ((length == 0) || (length > 5)) { /* longest valid boolean string rep. is "false" */ - goto badBoolean; + return TCL_ERROR; } switch (str[0]) { @@ -1447,13 +1415,13 @@ SetBooleanFromAny(interp, objPtr) newBool = 0; goto numericBoolean; } - goto badBoolean; + return TCL_ERROR; case '1': if (length == 1) { newBool = 1; goto numericBoolean; } - goto badBoolean; + return TCL_ERROR; } /* @@ -1473,7 +1441,7 @@ SetBooleanFromAny(interp, objPtr) lowerCase[i] = c; break; default: - goto badBoolean; + return TCL_ERROR; } } lowerCase[length] = 0; @@ -1486,28 +1454,28 @@ SetBooleanFromAny(interp, objPtr) newBool = 1; goto goodBoolean; } - goto badBoolean; + return TCL_ERROR; case 'n': if (strncmp(lowerCase, "no", (size_t) length) == 0) { newBool = 0; goto goodBoolean; } - goto badBoolean; + return TCL_ERROR; case 't': if (strncmp(lowerCase, "true", (size_t) length) == 0) { newBool = 1; goto goodBoolean; } - goto badBoolean; + return TCL_ERROR; case 'f': if (strncmp(lowerCase, "false", (size_t) length) == 0) { newBool = 0; goto goodBoolean; } - goto badBoolean; + return TCL_ERROR; case 'o': if (length < 2) { - goto badBoolean; + return TCL_ERROR; } if (strncmp(lowerCase, "on", (size_t) length) == 0) { newBool = 1; @@ -1516,9 +1484,9 @@ SetBooleanFromAny(interp, objPtr) newBool = 0; goto goodBoolean; } - goto badBoolean; + return TCL_ERROR; default: - goto badBoolean; + return TCL_ERROR; } /* @@ -1533,17 +1501,6 @@ SetBooleanFromAny(interp, objPtr) objPtr->typePtr = &tclBooleanType; return TCL_OK; - badBoolean: - if (interp != NULL) { - Tcl_Obj *msg = - Tcl_NewStringObj("expected boolean value but got \"", -1); - str = Tcl_GetStringFromObj(objPtr, &length); - TclAppendLimitedToObj(msg, str, length, 50, ""); - Tcl_AppendToObj(msg, "\"", -1); - Tcl_SetObjResult(interp, msg); - } - return TCL_ERROR; - numericBoolean: TclFreeIntRep(objPtr); objPtr->internalRep.longValue = newBool; @@ -1712,29 +1669,36 @@ Tcl_GetDoubleFromObj(interp, objPtr, dblPtr) register Tcl_Obj *objPtr; /* The object from which to get a double. */ register double *dblPtr; /* Place to store resulting double. */ { - register int result; - - if (objPtr->typePtr == &tclIntType) { - *dblPtr = objPtr->internalRep.longValue; - return TCL_OK; - } else if (objPtr->typePtr == &tclWideIntType) { - *dblPtr = (double) objPtr->internalRep.wideValue; - return TCL_OK; - } else if (objPtr->typePtr != &tclDoubleType) { - result = SetDoubleFromAny(interp, objPtr); - if (result != TCL_OK) { - return TCL_ERROR; + do { + if (objPtr->typePtr == &tclDoubleType) { + if (TclIsNaN(objPtr->internalRep.doubleValue)) { + if (interp != NULL) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "floating point value is Not a Number", -1)); + } + return TCL_ERROR; + } + *dblPtr = (double) objPtr->internalRep.doubleValue; + return TCL_OK; } - } - if (IS_NAN(objPtr->internalRep.doubleValue)) { - if (interp != NULL) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "floating point value is Not a Number", -1)); + if (objPtr->typePtr == &tclIntType) { + *dblPtr = objPtr->internalRep.longValue; + return TCL_OK; } - return TCL_ERROR; - } - *dblPtr = objPtr->internalRep.doubleValue; - return TCL_OK; + if (objPtr->typePtr == &tclBignumType) { + mp_int big; + UNPACK_BIGNUM( objPtr, big ); + *dblPtr = TclBignumToDouble( &big ); + return TCL_OK; + } +#ifndef NO_WIDE_TYPE + if (objPtr->typePtr == &tclWideIntType) { + *dblPtr = (double) objPtr->internalRep.wideValue; + return TCL_OK; + } +#endif + } while (SetDoubleFromAny(interp, objPtr) == TCL_OK); + return TCL_ERROR; } /* @@ -1762,66 +1726,8 @@ SetDoubleFromAny(interp, objPtr) Tcl_Interp *interp; /* Used for error reporting if not NULL. */ register Tcl_Obj *objPtr; /* The object to convert. */ { - CONST char *string, *end; - double newDouble; - int length; - - /* - * Get the string representation. Make it up-to-date if necessary. - */ - - string = Tcl_GetStringFromObj(objPtr, &length); - - /* - * Now parse "objPtr"s string as an double. Numbers can't have embedded - * NULLs. We use an implementation here that doesn't report errors in - * interp if interp is NULL. - */ - - errno = 0; - newDouble = TclStrToD(string, &end); - if (end == string) { - badDouble: - if (interp != NULL) { - Tcl_Obj *msg = Tcl_NewStringObj( - "expected floating-point number but got \"", -1); - TclAppendLimitedToObj(msg, string, length, 50, ""); - Tcl_AppendToObj(msg, "\"", -1); - Tcl_SetObjResult(interp, msg); - } - return TCL_ERROR; - } - - /* - * Make sure that the string has no garbage after the end of the double. - */ - - while ((end < (string+length)) - && isspace(UCHAR(*end))) { /* INTL: ISO space. */ - end++; - } - if (end != (string+length)) { - goto badDouble; - } - - if (errno != 0 && errno != ERANGE) { - if (interp != NULL) { - TclExprFloatError(interp, newDouble); - } - return TCL_ERROR; - } - - /* - * The conversion to double succeeded. Free the old internalRep before - * setting the new one. We do this as late as possible to allow the - * conversion code, in particular Tcl_GetStringFromObj, to use that old - * internalRep. - */ - - TclFreeIntRep(objPtr); - objPtr->internalRep.doubleValue = newDouble; - objPtr->typePtr = &tclDoubleType; - return TCL_OK; + return TclParseNumber( interp, objPtr, "floating-point number", + NULL, -1, NULL, 0); } /* @@ -1976,44 +1882,21 @@ Tcl_GetIntFromObj(interp, objPtr, intPtr) register Tcl_Obj *objPtr; /* The object from which to get a int. */ register int *intPtr; /* Place to store resulting int. */ { - int result; - Tcl_WideInt w = 0; - - /* - * If the object isn't already an integer of any width, try to convert it - * to one. - */ - - if (objPtr->typePtr != &tclIntType && objPtr->typePtr != &tclWideIntType) { - result = SetIntOrWideFromAny(interp, objPtr); - if (result != TCL_OK) { - return result; - } - } - - /* - * Object should now be either int or wide. Get its value. - */ + long l; -#ifndef TCL_WIDE_INT_IS_LONG - if (objPtr->typePtr == &tclWideIntType) { - w = objPtr->internalRep.wideValue; - } else -#endif - { - w = Tcl_LongAsWide(objPtr->internalRep.longValue); + if (Tcl_GetLongFromObj(interp, objPtr, &l) != TCL_OK) { + return TCL_ERROR; } - - if ((LLONG_MAX > UINT_MAX) - && ((w > UINT_MAX) || (w < -(Tcl_WideInt)UINT_MAX))) { + if ((ULONG_MAX > UINT_MAX) && ((l > UINT_MAX) || (l < -(long)UINT_MAX))) { if (interp != NULL) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "integer value too large to represent as non-long integer", - -1)); + CONST char *s + = "integer value too large to represent as non-long integer"; + Tcl_SetObjResult(interp, Tcl_NewStringObj(s, -1)); + Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", s, (char *) NULL); } return TCL_ERROR; } - *intPtr = (int)w; + *intPtr = (int)l; return TCL_OK; } @@ -2038,144 +1921,8 @@ SetIntFromAny(interp, objPtr) Tcl_Interp* interp; /* Tcl interpreter */ Tcl_Obj* objPtr; /* Pointer to the object to convert */ { - int result; - - result = SetIntOrWideFromAny(interp, objPtr); - if (result != TCL_OK) { - return result; - } - if (objPtr->typePtr != &tclIntType) { - if (interp != NULL) { - CONST char *s = "integer value too large to represent"; - Tcl_SetObjResult(interp, Tcl_NewStringObj(s, -1)); - Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", s, (char *) NULL); - } - return TCL_ERROR; - } - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * SetIntOrWideFromAny -- - * - * Attempt to generate an integer internal form for the Tcl object - * "objPtr". - * - * Results: - * The return value is a standard object Tcl result. If an error occurs - * during conversion, an error message is left in the interpreter's - * result unless "interp" is NULL. - * - * Side effects: - * If no error occurs, an int is stored as "objPtr"s internal - * representation. - * - *---------------------------------------------------------------------- - */ - -static int -SetIntOrWideFromAny(interp, objPtr) - Tcl_Interp *interp; /* Used for error reporting if not NULL. */ - register Tcl_Obj *objPtr; /* The object to convert. */ -{ - char *string, *end; - int length; - register char *p; - unsigned long newLong; - int isNegative = 0; - - /* - * Get the string representation. Make it up-to-date if necessary. - */ - - p = string = Tcl_GetStringFromObj(objPtr, &length); - - /* - * Now parse "objPtr"s string as an int. We use an implementation here - * that doesn't report errors in interp if interp is NULL. Note: use - * strtoul instead of strtol for integer conversions to allow full-size - * unsigned numbers. We parse the leading space and sign ourselves so we - * can tell the difference between apparently positive and negative - * values. - */ - - errno = 0; - for (; isspace(UCHAR(*p)) ; p++) { /* INTL: ISO space. */ - /* Empty loop body. */ - } - if (*p == '-') { - isNegative = 1; - p++; - } else if (*p == '+') { - p++; - } - if (!isdigit(UCHAR(*p))) { - badInteger: - if (interp != NULL) { - Tcl_Obj *msg = - Tcl_NewStringObj("expected integer but got \"", -1); - TclAppendLimitedToObj(msg, string, length, 50, ""); - Tcl_AppendToObj(msg, "\"", -1); - Tcl_SetObjResult(interp, msg); - TclCheckBadOctal(interp, string); - } - return TCL_ERROR; - } - newLong = strtoul(p, &end, 0); - if (end == p) { - goto badInteger; - } - - /* - * Make sure that the string has no garbage after the end of the int. - */ - - while ((end < (string+length)) - && isspace(UCHAR(*end))) { /* INTL: ISO space. */ - end++; - } - if (end != (string+length)) { - goto badInteger; - } - - if (errno == ERANGE) { - if (interp != NULL) { - CONST char *s = "integer value too large to represent"; - Tcl_SetObjResult(interp, Tcl_NewStringObj(s, -1)); - Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", s, (char *) NULL); - } - return TCL_ERROR; - } - - /* - * The conversion to int succeeded. Free the old internalRep before - * setting the new one. We do this as late as possible to allow the - * conversion code, in particular Tcl_GetStringFromObj, to use that old - * internalRep. - */ - - TclFreeIntRep(objPtr); -#ifndef TCL_WIDE_INT_IS_LONG - /* - * If the resulting integer will exceed the range of a long, put it into a - * wide instead. (Tcl Bug #868489) - */ - - if ((isNegative && newLong > (unsigned long) (LONG_MAX) + 1) - || (!isNegative && newLong > LONG_MAX)) { - objPtr->internalRep.wideValue = - (isNegative ? -(Tcl_WideInt)newLong : (Tcl_WideInt)newLong); - objPtr->typePtr = &tclWideIntType; - } else -#endif - { - objPtr->internalRep.longValue = - (isNegative ? -(long)newLong : (long)newLong); - objPtr->typePtr = &tclIntType; - } - return TCL_OK; + long l; + return Tcl_GetLongFromObj(interp, objPtr, &l); } /* @@ -2392,142 +2139,81 @@ Tcl_GetLongFromObj(interp, objPtr, longPtr) register Tcl_Obj *objPtr; /* The object from which to get a long. */ register long *longPtr; /* Place to store resulting long. */ { - register int result; - - if (objPtr->typePtr != &tclIntType - && objPtr->typePtr != &tclWideIntType) { - result = SetIntOrWideFromAny(interp, objPtr); - if (result != TCL_OK) { - return result; + do { + if (objPtr->typePtr == &tclIntType) { + *longPtr = objPtr->internalRep.longValue; + return TCL_OK; } - } - -#ifndef TCL_WIDE_INT_IS_LONG - if (objPtr->typePtr == &tclWideIntType) { - /* - * If the object is already a wide integer, don't convert it. This - * code allows for any integer in the range -ULONG_MAX to ULONG_MAX to - * be converted to a long, ignoring overflow. The rule preserves - * existing semantics for conversion of integers on input, but avoids - * inadvertent demotion of wide integers to 32-bit ones in the - * internal rep. - */ +#ifndef NO_WIDE_TYPE + if (objPtr->typePtr == &tclWideIntType) { + /* + * We return any integer in the range -ULONG_MAX to ULONG_MAX + * converted to a long, ignoring overflow. The rule preserves + * existing semantics for conversion of integers on input, but + * avoids inadvertent demotion of wide integers to 32-bit ones + * in the internal rep. + */ - Tcl_WideInt w = objPtr->internalRep.wideValue; - if (w >= -(Tcl_WideInt)(ULONG_MAX) - && w <= (Tcl_WideInt)(ULONG_MAX)) { - *longPtr = Tcl_WideAsLong(w); - return TCL_OK; - } else { - if (interp != NULL) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "integer value too large to represent", -1)); + Tcl_WideInt w = objPtr->internalRep.wideValue; + if (w >= -(Tcl_WideInt)(ULONG_MAX) + && w <= (Tcl_WideInt)(ULONG_MAX)) { + *longPtr = Tcl_WideAsLong(w); + return TCL_OK; } - return TCL_ERROR; + goto tooLarge; } - } #endif - - *longPtr = objPtr->internalRep.longValue; - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * SetWideIntFromAny -- - * - * Attempt to generate an integer internal form for the Tcl object - * "objPtr". - * - * Results: - * The return value is a standard object Tcl result. If an error occurs - * during conversion, an error message is left in the interpreter's - * result unless "interp" is NULL. - * - * Side effects: - * If no error occurs, an int is stored as "objPtr"s internal - * representation. - * - *---------------------------------------------------------------------- - */ - -static int -SetWideIntFromAny(interp, objPtr) - Tcl_Interp *interp; /* Used for error reporting if not NULL. */ - register Tcl_Obj *objPtr; /* The object to convert. */ -{ -#ifndef TCL_WIDE_INT_IS_LONG - char *string, *end; - int length; - register char *p; - Tcl_WideInt newWide; - - /* - * Get the string representation. Make it up-to-date if necessary. - */ - - p = string = Tcl_GetStringFromObj(objPtr, &length); - - /* - * Now parse "objPtr"s string as an int. We use an implementation here - * that doesn't report errors in interp if interp is NULL. Note: use - * strtoull instead of strtoll for integer conversions to allow full-size - * unsigned numbers. - */ - - errno = 0; - newWide = strtoull(p, &end, 0); - if (end == p) { - badInteger: - if (interp != NULL) { - Tcl_Obj *msg = - Tcl_NewStringObj("expected integer but got \"", -1); - TclAppendLimitedToObj(msg, string, length, 50, ""); - Tcl_AppendToObj(msg, "\"", -1); - Tcl_SetObjResult(interp, msg); - TclCheckBadOctal(interp, string); - } - return TCL_ERROR; - } - - /* - * Make sure that the string has no garbage after the end of the int. - */ - - while ((end < (string+length)) - && isspace(UCHAR(*end))) { /* INTL: ISO space. */ - end++; - } - if (end != (string+length)) { - goto badInteger; - } - - if (errno == ERANGE) { - if (interp != NULL) { - CONST char *s = "integer value too large to represent"; - Tcl_SetObjResult(interp, Tcl_NewStringObj(s, -1)); - Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", s, (char *) NULL); + if (objPtr->typePtr == &tclDoubleType) { + if (interp != NULL) { + Tcl_Obj* msg = + Tcl_NewStringObj("expected integer but got \"", -1); + Tcl_AppendObjToObj(msg, objPtr); + Tcl_AppendToObj(msg, "\"", -1); + Tcl_SetObjResult(interp, msg); + } + return TCL_ERROR; } - return TCL_ERROR; - } - /* - * The conversion to int succeeded. Free the old internalRep before - * setting the new one. We do this as late as possible to allow the - * conversion code, in particular Tcl_GetStringFromObj, to use that old - * internalRep. - */ - - TclFreeIntRep(objPtr); - objPtr->internalRep.wideValue = newWide; -#else - if (TCL_ERROR == SetIntFromAny(interp, objPtr)) { - return TCL_ERROR; - } + if (objPtr->typePtr == &tclBignumType) { + /* Must check for those bignum values that can fit in + * a long, even when auto-narrowing is enabled. Only those + * values in the signed long range get auto-narrowed to + * tclIntType, while all the values in the unsigned long + * range will fit in a long. */ + mp_int big; + UNPACK_BIGNUM(objPtr, big); + if (big.used <= (CHAR_BIT * sizeof(long) + DIGIT_BIT - 1) + / DIGIT_BIT) { + unsigned long value = 0, numBytes = sizeof(long); + long scratch; + unsigned char *bytes = (unsigned char *)&scratch; + if (mp_to_unsigned_bin_n(&big, bytes, &numBytes) == MP_OKAY) { + while (numBytes-- > 0) { + value = (value << CHAR_BIT) | *bytes++; + } + if (big.sign) { + *longPtr = - (long) value; + } else { + *longPtr = (long) value; + } + return TCL_OK; + } + } +#ifndef NO_WIDE_TYPE + tooLarge: #endif - objPtr->typePtr = &tclWideIntType; - return TCL_OK; + if (interp != NULL) { + char *s = "integer value too large to represent"; + Tcl_Obj* msg = Tcl_NewStringObj(s, -1); + Tcl_SetObjResult(interp, msg); + Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", s, (char *)NULL); + } + return TCL_ERROR; + } + } while (TclParseNumber(interp, objPtr, "integer", NULL, -1, NULL, + TCL_PARSE_INTEGER_ONLY)==TCL_OK); + return TCL_ERROR; } +#ifndef NO_WIDE_TYPE /* *---------------------------------------------------------------------- @@ -2548,7 +2234,6 @@ SetWideIntFromAny(interp, objPtr) *---------------------------------------------------------------------- */ -#ifndef TCL_WIDE_INT_IS_LONG static void UpdateStringOfWideInt(objPtr) register Tcl_Obj *objPtr; /* Int object whose string rep to update. */ @@ -2570,7 +2255,7 @@ UpdateStringOfWideInt(objPtr) memcpy(objPtr->bytes, buffer, len + 1); objPtr->length = len; } -#endif /* TCL_WIDE_INT_IS_LONG */ +#endif /* !NO_WIDE_TYPE */ /* *---------------------------------------------------------------------- @@ -2617,7 +2302,8 @@ Tcl_NewWideIntObj(wideValue) { register Tcl_Obj *objPtr; - TclNewWideIntObj(objPtr, wideValue); + TclNewObj(objPtr); + Tcl_SetWideIntObj(objPtr, wideValue); return objPtr; } #endif /* if TCL_MEM_DEBUG */ @@ -2669,10 +2355,7 @@ Tcl_DbNewWideIntObj(wideValue, file, line) register Tcl_Obj *objPtr; TclDbNewObj(objPtr, file, line); - objPtr->bytes = NULL; - - objPtr->internalRep.wideValue = wideValue; - objPtr->typePtr = &tclWideIntType; + Tcl_SetWideIntObj(objPtr, wideValue); return objPtr; } @@ -2720,7 +2403,18 @@ Tcl_SetWideIntObj(objPtr, wideValue) Tcl_Panic("Tcl_SetWideIntObj called with shared object"); } - TclSetWideIntObj(objPtr, wideValue); + if ((wideValue >= (Tcl_WideInt) LONG_MIN) + && (wideValue <= (Tcl_WideInt) LONG_MAX)) { + TclSetLongObj(objPtr, (long) wideValue); + } else { +#ifndef NO_WIDE_TYPE + TclSetWideIntObj(objPtr, wideValue); +#else + mp_int big; + TclBNInitBignumFromWideInt(&big, wideValue); + Tcl_SetBignumObj(objPtr, &big); +#endif + } } /* @@ -2750,17 +2444,61 @@ Tcl_GetWideIntFromObj(interp, objPtr, wideIntPtr) register Tcl_Obj *objPtr; /* Object from which to get a wide int. */ register Tcl_WideInt *wideIntPtr; /* Place to store resulting long. */ { - register int result; - - if (objPtr->typePtr == &tclWideIntType) { - *wideIntPtr = objPtr->internalRep.wideValue; - return TCL_OK; - } - result = SetWideIntFromAny(interp, objPtr); - if (result == TCL_OK) { - *wideIntPtr = objPtr->internalRep.wideValue; - } - return result; + do { +#ifndef NO_WIDE_TYPE + if (objPtr->typePtr == &tclWideIntType) { + *wideIntPtr = objPtr->internalRep.wideValue; + return TCL_OK; + } +#endif + if (objPtr->typePtr == &tclIntType) { + *wideIntPtr = (Tcl_WideInt) objPtr->internalRep.longValue; + return TCL_OK; + } + if (objPtr->typePtr == &tclDoubleType) { + if (interp != NULL) { + Tcl_Obj* msg = + Tcl_NewStringObj("expected integer but got \"", -1); + Tcl_AppendObjToObj(msg, objPtr); + Tcl_AppendToObj(msg, "\"", -1); + Tcl_SetObjResult(interp, msg); + } + return TCL_ERROR; + } + if (objPtr->typePtr == &tclBignumType) { + /* Must check for those bignum values that can fit in + * a Tcl_WideInt, even when auto-narrowing is enabled. */ + mp_int big; + UNPACK_BIGNUM(objPtr, big); + if (big.used <= (CHAR_BIT * sizeof(Tcl_WideInt) + DIGIT_BIT - 1) + / DIGIT_BIT) { + Tcl_WideUInt value = 0; + unsigned long numBytes = sizeof(Tcl_WideInt); + Tcl_WideInt scratch; + unsigned char *bytes = (unsigned char *)&scratch; + if (mp_to_unsigned_bin_n(&big, bytes, &numBytes) == MP_OKAY) { + while (numBytes-- > 0) { + value = (value << CHAR_BIT) | *bytes++; + } + if (big.sign) { + *wideIntPtr = - (Tcl_WideInt) value; + } else { + *wideIntPtr = (Tcl_WideInt) value; + } + return TCL_OK; + } + } + if (interp != NULL) { + char *s = "integer value too large to represent"; + Tcl_Obj* msg = Tcl_NewStringObj(s, -1); + Tcl_SetObjResult(interp, msg); + Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", s, (char *)NULL); + } + return TCL_ERROR; + } + } while (TclParseNumber(interp, objPtr, "integer", NULL, -1, NULL, + TCL_PARSE_INTEGER_ONLY)==TCL_OK); + return TCL_ERROR; } /* @@ -2783,6 +2521,9 @@ FreeBignum(Tcl_Obj *objPtr) UNPACK_BIGNUM(objPtr, toFree); mp_clear(&toFree); + if (objPtr->internalRep.ptrAndLongRep.value < 0) { + ckfree((char *)objPtr->internalRep.ptrAndLongRep.ptr); + } } /* @@ -2814,129 +2555,7 @@ DupBignum(srcPtr, copyPtr) if (mp_init_copy(&bignumCopy, &bignumVal) != MP_OKAY) { Tcl_Panic("initialization failure in DupBignum"); } - PACK_BIGNUM(bignumVal, copyPtr); -} - -/* - *---------------------------------------------------------------------- - * - * SetBignumFromAny -- - * - * This procedure interprets a Tcl_Obj as a bignum and sets the internal - * representation accordingly. - * - * Results: - * Returns a standard Tcl status. If conversion fails, an error message - * is left in the interpreter result. - * - * Side effects: - * The bignum internal representation is packed into the object. - * - *---------------------------------------------------------------------- - */ - -static int -SetBignumFromAny(interp, objPtr) - Tcl_Interp* interp; - Tcl_Obj* objPtr; -{ - CONST char* stringVal; - CONST char* p; - int length; - int signum = MP_ZPOS; - int radix = 10; - int status; - mp_int bignumVal; - - if (objPtr->typePtr == &tclIntType) { - - /* - * If the number already contains an integer, simply widen it to a - * bignum. - */ - - TclBNInitBignumFromLong(&bignumVal, objPtr->internalRep.longValue); - } else { - - /* - * The number doesn't contain an integer. Convert its string rep to a - * bignum, handling 0XXX and 0xXXX notation - */ - - stringVal = Tcl_GetStringFromObj(objPtr, &length); - p = stringVal; - - /* - * Pull off the signum - */ - - if (*p == '+') { - ++p; - } else if (*p == '-') { - ++p; - signum = MP_NEG; - } - - /* - * Handle octal and hexadecimal - */ - - if (*p == '0') { - ++p; - if (*p == 'x' || *p == 'X') { - ++p; - radix = 16; - } else { - --p; - radix = 8; - } - } - - /* Convert the value */ - - if (mp_init(&bignumVal) != MP_OKAY) { - Tcl_Panic("initialization failure in SetBignumFromAny"); - } - status = mp_read_radix(&bignumVal, p, radix); - switch (status) { - case MP_MEM: - Tcl_Panic("out of memory in SetBignumFromAny"); - case MP_OKAY: - break; - default: - if (interp != NULL) { - Tcl_Obj* msg = Tcl_NewStringObj( - "expected integer but got \"", -1); - TclAppendLimitedToObj(msg, stringVal, length, 50, ""); - Tcl_AppendToObj(msg, "\"", -1); - Tcl_SetObjResult(interp, msg); - TclCheckBadOctal(interp, stringVal); - } - mp_clear(&bignumVal); - return TCL_ERROR; - } - - /* Conversion to bignum succeeded. Make sure that everything fits. */ - - if (bignumVal.alloc > 0x7fff) { - Tcl_Obj* msg = - Tcl_NewStringObj("integer value too large to represent",-1); - Tcl_SetObjResult(interp, msg); - mp_clear(&bignumVal); - return TCL_ERROR; - } - } - - /* - * Conversion succeeded. Clean up the old internal rep and store the new - * one. - */ - - TclFreeIntRep(objPtr); - bignumVal.sign = signum; - PACK_BIGNUM(bignumVal, objPtr); - objPtr->typePtr = &tclBignumType; - return TCL_OK; + PACK_BIGNUM(bignumCopy, copyPtr); } /* @@ -2970,6 +2589,23 @@ UpdateStringOfBignum(Tcl_Obj* objPtr) if (status != MP_OKAY) { Tcl_Panic("radix size failure in UpdateStringOfBignum"); } + if (size == 3 +#ifndef BIGNUM_AUTO_NARROW + && bignumVal.used > 1 +#endif + ) { + /* + * mp_radix_size() returns 3 when more than INT_MAX bytes would + * be needed to hold the string rep (because mp_radix_size + * ignores integer overflow issues). When we know the string + * rep will be more than 3, we can conclude the string rep would + * overflow our string length limits. + * + * Note that so long as we enforce our bignums to the size that + * fits in a packed bignum, this branch will never be taken. + */ + Tcl_Panic("UpdateStringOfBignum: string length limit exceeded"); + } stringVal = Tcl_Alloc((size_t) size); status = mp_toradix_n(&bignumVal, stringVal, 10, size); if (status != MP_OKAY) { @@ -3007,16 +2643,8 @@ Tcl_Obj * Tcl_NewBignumObj(mp_int* bignumValue) { Tcl_Obj* objPtr; - TclNewObj(objPtr); - PACK_BIGNUM(*bignumValue, objPtr); - objPtr->typePtr=&tclBignumType; - objPtr->bytes = NULL; - - /* Clear with mp_init; mp_clear would overwrite the digit array. */ - - mp_init(bignumValue); - + Tcl_SetBignumObj(objPtr, bignumValue); return objPtr; } #endif @@ -3046,15 +2674,7 @@ Tcl_DbNewBignumObj(mp_int* bignumValue, CONST char* file, int line) Tcl_Obj* objPtr; TclDbNewObj(objPtr, file, line); - objPtr->bytes = NULL; - PACK_BIGNUM(*bignumValue, objPtr); - objPtr->typePtr = &tclBignumType; - objPtr->bytes = NULL; - - /* Clear with mp_init; mp_clear would overwrite the digit array. */ - - mp_init(bignumValue); - + Tcl_SetBignumObj(objPtr, bignumValue); return objPtr; } #else @@ -3068,6 +2688,80 @@ Tcl_DbNewBignumObj(mp_int* bignumValue, CONST char* file, int line) /* *---------------------------------------------------------------------- * + * GetBignumFromObj -- + * + * This procedure retrieves a 'bignum' value from a Tcl object, + * converting the object if necessary. Either copies or transfers + * the mp_int value depending on the copy flag value passed in. + * + * Results: + * Returns TCL_OK if the conversion is successful, TCL_ERROR otherwise. + * + * Side effects: + * A copy of bignum is stored in *bignumValue, which is expected to be + * uninitialized or cleared. If conversion fails, and the 'interp' + * argument is not NULL, an error message is stored in the interpreter + * result. + * + *---------------------------------------------------------------------- + */ + +int +GetBignumFromObj( + Tcl_Interp* interp, /* Tcl interpreter for error reporting */ + Tcl_Obj* objPtr, /* Object to read */ + int copy, /* Whether to copy the returned bignum value */ + mp_int* bignumValue) /* Returned bignum value. */ +{ + do { + if (objPtr->typePtr == &tclBignumType) { + if (copy) { + mp_int temp; + UNPACK_BIGNUM(objPtr, temp); + mp_init_copy(bignumValue, &temp); + } else { + if (Tcl_IsShared(objPtr)) { + Tcl_Panic("Tcl_GetBignumAndClearObj called on shared Tcl_Obj"); + } + UNPACK_BIGNUM(objPtr, *bignumValue); + objPtr->internalRep.ptrAndLongRep.ptr = NULL; + objPtr->internalRep.ptrAndLongRep.value = 0; + objPtr->typePtr = NULL; + if (objPtr->bytes == NULL) { + TclInitStringRep(objPtr, NULL, 0); + } + } + return TCL_OK; + } + if (objPtr->typePtr == &tclIntType) { + TclBNInitBignumFromLong(bignumValue, objPtr->internalRep.longValue); + return TCL_OK; + } +#ifndef NO_WIDE_TYPE + if (objPtr->typePtr == &tclWideIntType) { + TclBNInitBignumFromWideInt(bignumValue, + objPtr->internalRep.wideValue); + return TCL_OK; + } +#endif + if (objPtr->typePtr == &tclDoubleType) { + if (interp != NULL) { + Tcl_Obj* msg = + Tcl_NewStringObj("expected integer but got \"", -1); + Tcl_AppendObjToObj(msg, objPtr); + Tcl_AppendToObj(msg, "\"", -1); + Tcl_SetObjResult(interp, msg); + } + return TCL_ERROR; + } + } while (TclParseNumber(interp, objPtr, "integer", NULL, -1, NULL, + TCL_PARSE_INTEGER_ONLY)==TCL_OK); + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * * Tcl_GetBignumFromObj -- * * This procedure retrieves a 'bignum' value from a Tcl object, @@ -3083,9 +2777,10 @@ Tcl_DbNewBignumObj(mp_int* bignumValue, CONST char* file, int line) * result. * * It is expected that the caller will NOT have invoked mp_init on the - * bignum value before passing it in. The raw value of the object is - * returned, and Tcl owns that memory, so the caller should NOT invoke - * mp_clear afterwards. + * bignum value before passing it in. Tcl will initialize the mp_int + * as it sets the value. The value is a copy of the value in objPtr, + * so it becomes the responsibility of the caller to call mp_clear on + * it. * *---------------------------------------------------------------------- */ @@ -3096,16 +2791,42 @@ Tcl_GetBignumFromObj( Tcl_Obj* objPtr, /* Object to read */ mp_int* bignumValue) /* Returned bignum value. */ { - mp_int temp; + return GetBignumFromObj(interp, objPtr, 1, bignumValue); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetBignumAndClearObj -- + * + * This procedure retrieves a 'bignum' value from a Tcl object, + * converting the object if necessary. + * + * Results: + * Returns TCL_OK if the conversion is successful, TCL_ERROR otherwise. + * + * Side effects: + * A copy of bignum is stored in *bignumValue, which is expected to be + * uninitialized or cleared. If conversion fails, an the 'interp' + * argument is not NULL, an error message is stored in the interpreter + * result. + * + * It is expected that the caller will NOT have invoked mp_init on the + * bignum value before passing it in. Tcl will initialize the mp_int + * as it sets the value. The value is transferred from the internals + * of objPtr to the caller, passing responsibility of the caller to + * call mp_clear on it. The objPtr is cleared to hold an empty value. + * + *---------------------------------------------------------------------- + */ - if (objPtr->typePtr != &tclBignumType) { - if (SetBignumFromAny(interp, objPtr) != TCL_OK) { - return TCL_ERROR; - } - } - UNPACK_BIGNUM(objPtr, temp); - mp_init_copy(bignumValue, &temp); - return TCL_OK; +int +Tcl_GetBignumAndClearObj( + Tcl_Interp* interp, /* Tcl interpreter for error reporting */ + Tcl_Obj* objPtr, /* Object to read */ + mp_int* bignumValue) /* Returned bignum value. */ +{ + return GetBignumFromObj(interp, objPtr, 0, bignumValue); } /* @@ -3133,14 +2854,132 @@ Tcl_SetBignumObj( if (Tcl_IsShared(objPtr)) { Tcl_Panic("Tcl_SetBignumObj called with shared object"); } +#ifdef BIGNUM_AUTO_NARROW + if (bignumValue->used + <= (CHAR_BIT * sizeof(long) + DIGIT_BIT - 1) / DIGIT_BIT) { + unsigned long value = 0, numBytes = sizeof(long); + long scratch; + unsigned char *bytes = (unsigned char *)&scratch; + if (mp_to_unsigned_bin_n(bignumValue, bytes, &numBytes) != MP_OKAY) { + goto tooLargeForLong; + } + while (numBytes-- > 0) { + value = (value << CHAR_BIT) | *bytes++; + } + if (value > (((~(unsigned long)0) >> 1) + bignumValue->sign)) { + goto tooLargeForLong; + } + if (bignumValue->sign) { + TclSetLongObj(objPtr, -(long)value); + } else { + TclSetLongObj(objPtr, (long)value); + } + mp_clear(bignumValue); + return; + } + tooLargeForLong: +#ifndef NO_WIDE_TYPE + if (bignumValue->used + <= (CHAR_BIT * sizeof(Tcl_WideInt) + DIGIT_BIT - 1) / DIGIT_BIT) { + Tcl_WideUInt value = 0; + unsigned long numBytes = sizeof(Tcl_WideInt); + Tcl_WideInt scratch; + unsigned char *bytes = (unsigned char *)&scratch; + if (mp_to_unsigned_bin_n(bignumValue, bytes, &numBytes) != MP_OKAY) { + goto tooLargeForWide; + } + while (numBytes-- > 0) { + value = (value << CHAR_BIT) | *bytes++; + } + if (value > (((~(Tcl_WideUInt)0) >> 1) + bignumValue->sign)) { + goto tooLargeForWide; + } + if (bignumValue->sign) { + TclSetWideIntObj(objPtr, -(Tcl_WideInt)value); + } else { + TclSetWideIntObj(objPtr, (Tcl_WideInt)value); + } + mp_clear(bignumValue); + return; + } + tooLargeForWide: +#endif +#endif + TclInvalidateStringRep(objPtr); TclFreeIntRep(objPtr); + TclSetBignumIntRep(objPtr, bignumValue); +} + +void +TclSetBignumIntRep(objPtr, bignumValue) + Tcl_Obj *objPtr; + mp_int *bignumValue; +{ objPtr->typePtr = &tclBignumType; PACK_BIGNUM(*bignumValue, objPtr); - Tcl_InvalidateStringRep(objPtr); - /* Clear the value with mp_init; mp_clear overwrites the digit array. */ + /* + * Clear the mp_int value. + * Don't call mp_clear() because it would free the digit array + * we just packed into the Tcl_Obj. + */ - mp_init(bignumValue); + bignumValue->dp = NULL; + bignumValue->alloc = bignumValue->used = 0; + bignumValue->sign = MP_NEG; +} + +/* + *---------------------------------------------------------------------- + * + * TclGetNumberFromObj -- + * + * Results: + * + * Side effects: + * + *---------------------------------------------------------------------- + */ + +int TclGetNumberFromObj(interp, objPtr, clientDataPtr, typePtr) + Tcl_Interp *interp; + Tcl_Obj *objPtr; + ClientData *clientDataPtr; + int *typePtr; +{ + do { + if (objPtr->typePtr == &tclDoubleType) { + if (TclIsNaN(objPtr->internalRep.doubleValue)) { + *typePtr = TCL_NUMBER_NAN; + } else { + *typePtr = TCL_NUMBER_DOUBLE; + } + *clientDataPtr = &(objPtr->internalRep.doubleValue); + return TCL_OK; + } + if (objPtr->typePtr == &tclIntType) { + *typePtr = TCL_NUMBER_LONG; + *clientDataPtr = &(objPtr->internalRep.longValue); + return TCL_OK; + } +#ifndef NO_WIDE_TYPE + if (objPtr->typePtr == &tclWideIntType) { + *typePtr = TCL_NUMBER_WIDE; + *clientDataPtr = &(objPtr->internalRep.wideValue); + return TCL_OK; + } +#endif + if (objPtr->typePtr == &tclBignumType) { + static Tcl_ThreadDataKey bignumKey; + mp_int *bigPtr = Tcl_GetThreadData(&bignumKey, (int)sizeof(mp_int)); + UNPACK_BIGNUM( objPtr, *bigPtr ); + *typePtr = TCL_NUMBER_BIG; + *clientDataPtr = bigPtr; + return TCL_OK; + } + } while (TCL_OK == + TclParseNumber(interp, objPtr, "number", NULL, -1, NULL, 0)); + return TCL_ERROR; } /* diff --git a/generic/tclParseExpr.c b/generic/tclParseExpr.c index b6f3548..d617300 100644 --- a/generic/tclParseExpr.c +++ b/generic/tclParseExpr.c @@ -12,27 +12,12 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclParseExpr.c,v 1.27 2005/07/21 14:38:50 dkf Exp $ + * RCS: @(#) $Id: tclParseExpr.c,v 1.28 2005/10/08 14:42:45 dgp Exp $ */ #include "tclInt.h" /* - * The stuff below is a bit of a hack so that this file can be used in - * environments that include no UNIX, i.e. no errno: just arrange to use the - * errno from tclExecute.c here. - */ - -#ifdef TCL_GENERIC_ONLY -#define NO_ERRNO_H -#endif - -#ifdef NO_ERRNO_H -extern int errno; /* Use errno from tclExecute.c. */ -#define ERANGE 34 -#endif - -/* * Boolean variable that controls whether expression parse tracing is enabled. */ @@ -166,8 +151,6 @@ static int ParseCondExpr _ANSI_ARGS_((ParseInfo *infoPtr)); static int ParseEqualityExpr _ANSI_ARGS_((ParseInfo *infoPtr)); static int ParseLandExpr _ANSI_ARGS_((ParseInfo *infoPtr)); static int ParseLorExpr _ANSI_ARGS_((ParseInfo *infoPtr)); -static int ParseMaxDoubleLength _ANSI_ARGS_((CONST char *string, - CONST char *end)); static int ParseMultiplyExpr _ANSI_ARGS_((ParseInfo *infoPtr)); static int ParsePrimaryExpr _ANSI_ARGS_((ParseInfo *infoPtr)); static int ParseRelationalExpr _ANSI_ARGS_((ParseInfo *infoPtr)); @@ -1589,7 +1572,6 @@ GetLexeme(infoPtr) char c; int offset, length, numBytes; Tcl_Parse *parsePtr = infoPtr->parsePtr; - Tcl_Interp *interp = parsePtr->interp; Tcl_UniChar ch; /* @@ -1632,59 +1614,16 @@ GetLexeme(infoPtr) c = *src; if ((c != '+') && (c != '-')) { CONST char *end = infoPtr->lastChar; - if ((length = TclParseInteger(src, end-src))) { - /* - * First length bytes look like an integer. Verify by attempting - * the conversion to the largest integer we have. - */ - - int code; - Tcl_WideInt wide; - Tcl_Obj *value = Tcl_NewStringObj(src, length); - - Tcl_IncrRefCount(value); - code = Tcl_GetWideIntFromObj(interp, value, &wide); - Tcl_DecrRefCount(value); - if (code == TCL_ERROR) { - parsePtr->errorType = TCL_PARSE_BAD_NUMBER; - return TCL_ERROR; - } - infoPtr->lexeme = LITERAL; - infoPtr->start = src; - infoPtr->size = length; - infoPtr->next = (src + length); - parsePtr->term = infoPtr->next; - return TCL_OK; - } else if ((length = ParseMaxDoubleLength(src, end))) { - /* - * There are length characters that could be a double. Let - * strtod() tells us for sure. Need a writable copy so we can set - * an terminating NULL to keep strtod from scanning too far. - */ - - char *startPtr; - CONST char *termPtr; - double doubleValue; - Tcl_DString toParse; - - errno = 0; - Tcl_DStringInit(&toParse); - startPtr = Tcl_DStringAppend(&toParse, src, length); - doubleValue = TclStrToD(startPtr, &termPtr); - Tcl_DStringFree(&toParse); - if (termPtr != startPtr) { - /* - * startPtr was the start of a valid double, copied from src. - */ - + CONST char* end2; + int code = TclParseNumber(NULL, NULL, NULL, + src, (unsigned)(end-src), &end2, 0); + if ( code == TCL_OK ) { + length = end2-src; + if ( length > 0 ) { infoPtr->lexeme = LITERAL; infoPtr->start = src; - if ((termPtr - startPtr) > length) { - infoPtr->size = length; - } else { - infoPtr->size = (termPtr - startPtr); - } - infoPtr->next = src + infoPtr->size; + infoPtr->size = length; + infoPtr->next = (src + length); parsePtr->term = infoPtr->next; return TCL_OK; } @@ -1932,6 +1871,7 @@ GetLexeme(infoPtr) } } +#if 0 /* *---------------------------------------------------------------------- * @@ -1991,55 +1931,7 @@ TclParseInteger(string, numBytes) } return 0; } - -/* - *---------------------------------------------------------------------- - * - * ParseMaxDoubleLength -- - * - * Scans a sequence of bytes checking that the characters could be in a - * string rep of a double. - * - * Results: - * Returns the number of bytes starting with string, running to, but not - * including end, all of which could be part of a string rep. of a - * double. Only character identity is used, no actual parsing is done. - * - * The legal bytes are '0' - '9', 'A' - 'F', 'a' - 'f', '.', '+', '-', - * 'i', 'I', 'n', 'N', 'p', 'P', 'x', and 'X'. This covers the values - * "Inf" and "Nan" as well as the decimal and hexadecimal representations - * recognized by a C99-compliant strtod(). - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static int -ParseMaxDoubleLength(string, end) - register CONST char *string;/* The string to examine. */ - CONST char *end; /* Point to the first character past the end - * of the string we are examining. */ -{ - CONST char *p = string; - while (p < end) { - switch (*p) { - case '0': case '1': case '2': case '3': case '4': case '5': - case '6': case '7': case '8': case '9': case 'A': case 'B': - case 'C': case 'D': case 'E': case 'F': case 'I': case 'N': - case 'P': case 'X': case 'a': case 'b': case 'c': case 'd': - case 'e': case 'f': case 'i': case 'n': case 'p': case 'x': - case '.': case '+': case '-': case '(': case ' ': case ')': - p++; - break; - default: - goto done; - } - } - done: - return (p - string); -} +#endif /* *---------------------------------------------------------------------- diff --git a/generic/tclProc.c b/generic/tclProc.c index b184c8a..b6f73e7 100644 --- a/generic/tclProc.c +++ b/generic/tclProc.c @@ -10,7 +10,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclProc.c,v 1.80 2005/09/15 16:40:02 dgp Exp $ + * RCS: @(#) $Id: tclProc.c,v 1.81 2005/10/08 14:42:45 dgp Exp $ */ #include "tclInt.h" @@ -669,8 +669,12 @@ TclObjGetFrame(interp, objPtr, framePtrPtr) if (level < 0) { goto levelError; } - } else if (objPtr->typePtr == &tclIntType || - objPtr->typePtr == &tclWideIntType) { + /* TODO: Consider skipping the typePtr checks */ + } else if (objPtr->typePtr == &tclIntType +#ifndef NO_WIDE_TYPE + || objPtr->typePtr == &tclWideIntType +#endif + ) { if (Tcl_GetIntFromObj(NULL, objPtr, &level) != TCL_OK || level < 0) { goto levelError; } @@ -683,6 +687,8 @@ TclObjGetFrame(interp, objPtr, framePtrPtr) /* * Cache for future reference. + * + * TODO: Use the new ptrAndLongRep intrep */ TclFreeIntRep(objPtr); @@ -696,6 +702,8 @@ TclObjGetFrame(interp, objPtr, framePtrPtr) /* * Cache for future reference. + * + * TODO: Use the new ptrAndLongRep intrep */ TclFreeIntRep(objPtr); diff --git a/generic/tclScan.c b/generic/tclScan.c index 54f9b78..eede9f3 100644 --- a/generic/tclScan.c +++ b/generic/tclScan.c @@ -8,7 +8,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclScan.c,v 1.18 2005/07/21 14:38:51 dkf Exp $ + * RCS: @(#) $Id: tclScan.c,v 1.19 2005/10/08 14:42:45 dgp Exp $ */ #include "tclInt.h" @@ -22,14 +22,17 @@ #define SCAN_UNSIGNED 0x4 /* Read an unsigned value. */ #define SCAN_WIDTH 0x8 /* A width value was supplied. */ +#if 0 #define SCAN_SIGNOK 0x10 /* A +/- character is allowed. */ #define SCAN_NODIGITS 0x20 /* No digits have been scanned. */ #define SCAN_NOZERO 0x40 /* No zero digits have been scanned. */ #define SCAN_XOK 0x80 /* An 'x' is allowed. */ #define SCAN_PTOK 0x100 /* Decimal point is allowed. */ #define SCAN_EXPOK 0x200 /* An exponent is allowed. */ +#endif #define SCAN_LONGER 0x400 /* Asked for a wide value. */ +#define SCAN_BIG 0x800 /* Asked for a bignum value. */ /* * The following structure contains the information associated with a @@ -366,6 +369,12 @@ ValidateFormat(interp, format, numVars, totalSubs) switch (ch) { case 'l': + if (*format == 'l') { + flags |= SCAN_BIG; + format += 1; + format += Tcl_UtfToUniChar(format, &ch); + break; + } case 'L': flags |= SCAN_LONGER; case 'h': @@ -393,11 +402,11 @@ ValidateFormat(interp, format, numVars, totalSubs) */ case 'n': case 's': - if (flags & SCAN_LONGER) { - invalidLonger: + if (flags & (SCAN_LONGER|SCAN_BIG)) { + invalidFieldSize: buf[Tcl_UniCharToUtf(ch, buf)] = '\0'; Tcl_AppendResult(interp, - "'l' modifier may not be specified in %", buf, + "field size modifier may not be specified in %", buf, " conversion", NULL); goto error; } @@ -410,15 +419,21 @@ ValidateFormat(interp, format, numVars, totalSubs) case 'g': case 'i': case 'o': - case 'u': case 'x': break; + case 'u': + if (flags & SCAN_BIG) { + Tcl_SetResult(interp, + "unsigned bignum scans are invalid", TCL_STATIC); + goto error; + } + break; /* * Bracket terms need special checking */ case '[': - if (flags & SCAN_LONGER) { - goto invalidLonger; + if (flags & (SCAN_LONGER|SCAN_BIG)) { + goto invalidFieldSize; } if (*format == '\0') { goto badSet; @@ -574,22 +589,24 @@ Tcl_ScanObjCmd(dummy, interp, objc, objv) int numVars, nconversions, totalVars = -1; int objIndex, offset, i, result, code; long value; - char *string, *end, *baseString; + CONST char *string, *end, *baseString; char op = 0; - int base = 0; int underflow = 0; size_t width; - long (*fn) _ANSI_ARGS_((char*,void*,int)) = NULL; -#ifndef TCL_WIDE_INT_IS_LONG - Tcl_WideInt (*lfn) _ANSI_ARGS_((char*,void*,int)) = NULL; Tcl_WideInt wideValue; -#endif Tcl_UniChar ch, sch; Tcl_Obj **objs = NULL, *objPtr = NULL; int flags; char buf[513]; /* Temporary buffer to hold scanned number * strings before they are passed to * strtoul. */ +#if 0 + int base = 0; + long (*fn) _ANSI_ARGS_((char*,void*,int)) = NULL; +#ifndef TCL_WIDE_INT_IS_LONG + Tcl_WideInt (*lfn) _ANSI_ARGS_((char*,void*,int)) = NULL; +#endif +#endif if (objc < 3) { Tcl_WrongNumArgs(interp, 1, objv, @@ -631,6 +648,7 @@ Tcl_ScanObjCmd(dummy, interp, objc, objv) objIndex = 0; nconversions = 0; while (*format != '\0') { + int parseFlag = 0; format += Tcl_UtfToUniChar(format, &ch); flags = 0; @@ -678,9 +696,10 @@ Tcl_ScanObjCmd(dummy, interp, objc, objv) flags |= SCAN_SUPPRESS; format += Tcl_UtfToUniChar(format, &ch); } else if ((ch < 0x80) && isdigit(UCHAR(ch))) { /* INTL: "C" locale. */ - value = strtoul(format-1, &end, 10); /* INTL: "C" locale. */ - if (*end == '$') { - format = end+1; + char *formatEnd; + value = strtoul(format-1, &formatEnd, 10);/* INTL: "C" locale. */ + if (*formatEnd == '$') { + format = formatEnd+1; format += Tcl_UtfToUniChar(format, &ch); objIndex = (int) value - 1; } @@ -703,6 +722,12 @@ Tcl_ScanObjCmd(dummy, interp, objc, objv) switch (ch) { case 'l': + if (*format == 'l') { + flags |= SCAN_BIG; + format += 1; + format += Tcl_UtfToUniChar(format, &ch); + break; + } case 'L': flags |= SCAN_LONGER; /* @@ -728,44 +753,58 @@ Tcl_ScanObjCmd(dummy, interp, objc, objv) case 'd': op = 'i'; + parseFlag = TCL_PARSE_DECIMAL_ONLY; +#if 0 base = 10; fn = (long (*) _ANSI_ARGS_((char*,void*,int)))strtol; #ifndef TCL_WIDE_INT_IS_LONG lfn = (Tcl_WideInt (*)_ANSI_ARGS_((char*,void*,int)))strtoll; #endif +#endif break; case 'i': op = 'i'; + parseFlag = TCL_PARSE_SCAN_PREFIXES; +#if 0 base = 0; fn = (long (*)_ANSI_ARGS_((char*,void*,int)))strtol; #ifndef TCL_WIDE_INT_IS_LONG lfn = (Tcl_WideInt (*)_ANSI_ARGS_((char*,void*,int)))strtoll; #endif +#endif break; case 'o': op = 'i'; + parseFlag = TCL_PARSE_OCTAL_ONLY | TCL_PARSE_SCAN_PREFIXES; +#if 0 base = 8; fn = (long (*)_ANSI_ARGS_((char*,void*,int)))strtoul; #ifndef TCL_WIDE_INT_IS_LONG lfn = (Tcl_WideInt (*)_ANSI_ARGS_((char*,void*,int)))strtoull; #endif +#endif break; case 'x': op = 'i'; + parseFlag = TCL_PARSE_HEXADECIMAL_ONLY; +#if 0 base = 16; fn = (long (*)_ANSI_ARGS_((char*,void*,int)))strtoul; #ifndef TCL_WIDE_INT_IS_LONG lfn = (Tcl_WideInt (*)_ANSI_ARGS_((char*,void*,int)))strtoull; #endif +#endif break; case 'u': op = 'i'; - base = 10; flags |= SCAN_UNSIGNED; +#if 0 + base = 10; fn = (long (*)_ANSI_ARGS_((char*,void*,int)))strtoul; #ifndef TCL_WIDE_INT_IS_LONG lfn = (Tcl_WideInt (*)_ANSI_ARGS_((char*,void*,int)))strtoull; #endif +#endif break; case 'f': @@ -903,6 +942,7 @@ Tcl_ScanObjCmd(dummy, interp, objc, objv) * Scan an unsigned or signed integer. */ +#if 0 if ((width == 0) || (width > sizeof(buf) - 1)) { width = sizeof(buf) - 1; } @@ -1049,111 +1089,91 @@ Tcl_ScanObjCmd(dummy, interp, objc, objv) } break; - - case 'f': - /* - * Scan a floating point number - */ - - if ((width == 0) || (width > sizeof(buf) - 1)) { - width = sizeof(buf) - 1; +#else + objPtr = Tcl_NewLongObj(0); + Tcl_IncrRefCount(objPtr); + if (width == 0) { + width = -1; } - flags &= ~SCAN_LONGER; - flags |= SCAN_SIGNOK | SCAN_NODIGITS | SCAN_PTOK | SCAN_EXPOK; - for (end = buf; width > 0; width--) { - switch (*string) { - case '0': case '1': case '2': case '3': - case '4': case '5': case '6': case '7': - case '8': case '9': - flags &= ~(SCAN_SIGNOK | SCAN_NODIGITS); - goto addToFloat; - case '+': case '-': - if (flags & SCAN_SIGNOK) { - flags &= ~SCAN_SIGNOK; - goto addToFloat; - } - break; - case '.': - if (flags & SCAN_PTOK) { - flags &= ~(SCAN_SIGNOK | SCAN_PTOK); - goto addToFloat; - } - break; - case 'e': case 'E': - /* - * An exponent is not allowed until there has been at - * least one digit. - */ - - if ((flags & (SCAN_NODIGITS | SCAN_EXPOK)) == SCAN_EXPOK) { - flags = (flags & ~(SCAN_EXPOK|SCAN_PTOK)) - | SCAN_SIGNOK | SCAN_NODIGITS; - goto addToFloat; + if (TclParseNumber(NULL, objPtr, NULL, string, width, &end, + TCL_PARSE_INTEGER_ONLY | parseFlag) != TCL_OK) { + Tcl_DecrRefCount(objPtr); + /* TODO: set underflow? test scan-4.44 */ + goto done; + } + string = end; + if (flags & SCAN_SUPPRESS) { + Tcl_DecrRefCount(objPtr); + break; + } + if (flags & SCAN_LONGER) { + if (Tcl_GetWideIntFromObj(NULL, objPtr, &wideValue) != TCL_OK) { + wideValue = ~(Tcl_WideUInt)0 >> 1; /* WIDE_MAX */ + if (Tcl_GetString(objPtr)[0] == '-') { + wideValue++; /* WIDE_MAX + 1 = WIDE_MIN */ } - break; } - - /* - * We got an illegal character so we are done accumulating. - */ - - break; - - addToFloat: - /* - * Add the character to the temporary buffer. - */ - - *end++ = *string++; - if (*string == '\0') { - break; + if ((flags & SCAN_UNSIGNED) && (wideValue < 0)) { + sprintf(buf, "%" TCL_LL_MODIFIER "u", + (Tcl_WideUInt)wideValue); + Tcl_SetStringObj(objPtr, buf, -1); + } else { + Tcl_SetWideIntObj(objPtr, wideValue); } - } - - /* - * Check to see if we need to back up because we saw a trailing - * 'e' or sign. - */ - - if (flags & SCAN_NODIGITS) { - if (flags & SCAN_EXPOK) { - /* - * There were no digits at all so scanning has failed and - * we are done. - */ - - if (*string == '\0') { - underflow = 1; + } else if (!(flags & SCAN_BIG)) { + if (Tcl_GetLongFromObj(NULL, objPtr, &value) != TCL_OK) { + if (Tcl_GetString(objPtr)[0] == '-') { + value = LONG_MIN; + } else { + value = LONG_MAX; } - goto done; } - - /* - * We got a bad exponent ('e' and maybe a sign). - */ - - end--; - string--; - if (*end != 'e' && *end != 'E') { - end--; - string--; + if ((flags & SCAN_UNSIGNED) && (value < 0)) { + sprintf(buf, "%lu", value); /* INTL: ISO digit */ + Tcl_SetStringObj(objPtr, buf, -1); + } else { + Tcl_SetLongObj(objPtr, value); } } + objs[objIndex++] = objPtr; + break; +#endif + case 'f': /* - * Scan the value from the temporary buffer. + * Scan a floating point number */ - if (!(flags & SCAN_SUPPRESS)) { + objPtr = Tcl_NewDoubleObj(0.0); + Tcl_IncrRefCount(objPtr); + if (width == 0) { + width = -1; + } + if (TclParseNumber(NULL, objPtr, NULL, string, width, &end, + TCL_PARSE_DECIMAL_ONLY) != TCL_OK) { + /* TODO: set underflow? test scan-4.55 */ + Tcl_DecrRefCount(objPtr); + goto done; + } else if (flags & SCAN_SUPPRESS) { + Tcl_DecrRefCount(objPtr); + string = end; + } else { double dvalue; - - *end = '\0'; - dvalue = TclStrToD(buf, NULL); - objPtr = Tcl_NewDoubleObj(dvalue); - Tcl_IncrRefCount(objPtr); + if (Tcl_GetDoubleFromObj(NULL, objPtr, &dvalue) != TCL_OK) { +#ifdef ACCEPT_NAN + if (objPtr->typePtr == &tclDoubleType) { + dValue = objPtr->internalRep.doubleValue; + } else +#endif + { + Tcl_DecrRefCount(objPtr); + goto done; + } + } + Tcl_SetDoubleObj(objPtr, dvalue); objs[objIndex++] = objPtr; + string = end; } - break; } nconversions++; } diff --git a/generic/tclStrToD.c b/generic/tclStrToD.c index 68f6c30..7f8ecd5 100755 --- a/generic/tclStrToD.c +++ b/generic/tclStrToD.c @@ -1,21 +1,20 @@ /* *---------------------------------------------------------------------- * - * tclStrToD.c -- + * tclDouble.c -- * - * This file contains a TclStrToD procedure that handles conversion of - * string to double, with correct rounding even where extended precision - * is needed to achieve that. It also contains a TclDoubleDigits - * procedure that handles conversion of double to string (at least the - * significand), and several utility functions for interconverting - * 'double' and the integer types. + * This file contains a collection of procedures for managing + * conversions to/from floating-point in Tcl. They include + * TclParseNumber, which parses numbers from strings; TclDoubleDigits, + * which formats numbers into strings of digits, and procedures for + * interconversion among 'double' and 'mp_int' types. * * Copyright (c) 2005 by Kevin B. Kenny. All rights reserved. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclStrToD.c,v 1.8 2005/08/24 15:15:45 kennykb Exp $ + * RCS: @(#) $Id: tclStrToD.c,v 1.9 2005/10/08 14:42:45 dgp Exp $ * *---------------------------------------------------------------------- */ @@ -30,34 +29,42 @@ #include <tommath.h> /* - * The stuff below is a bit of a hack so that this file can be used in - * environments that include no UNIX, i.e. no errno: just arrange to use the - * errno from tclExecute.c here. + * Define TIP_114_FORMATS to accept 0b and 0o for binary and octal strings. + * Define KILL_OCTAL as well as TIP_114_FORMATS to suppress interpretation + * of numbers with leading zero as octal. (Ceterum censeo: numeros octonarios + * delendos esse.) */ -#ifdef TCL_GENERIC_ONLY -# define NO_ERRNO_H -#endif +#define TIP_114_FORMATS +#undef KILL_OCTAL -#ifdef NO_ERRNO_H -extern int errno; /* Use errno from tclExecute.c. */ -# define ERANGE 34 +#ifndef TIP_114_FORMATS +#undef KILL_OCTAL #endif +/* + * This code supports (at least hypothetically), IBM, Cray, VAX and + * IEEE-754 floating point; of these, only IEEE-754 can represent NaN. + * IEEE-754 can be uniquely determined by radix and by the widths of + * significand and exponent. + */ + #if (FLT_RADIX == 2) && (DBL_MANT_DIG == 53) && (DBL_MAX_EXP == 1024) # define IEEE_FLOATING_POINT #endif /* - * gcc on x86 needs access to rounding controls. It is tempting to include - * fpu_control.h, but that file exists only on Linux; it is missing on Cygwin - * and MinGW. Most gcc-isms and ix86-isms are factored out here. + * gcc on x86 needs access to rounding controls, because of a questionable + * feature where it retains intermediate results as IEEE 'long double' values + * somewhat unpredictably. It is tempting to include fpu_control.h, but + * that file exists only on Linux; it is missing on Cygwin and MinGW. Most + * gcc-isms and ix86-isms are factored out here. */ #if defined(__GNUC__) && defined(__i386) typedef unsigned int fpu_control_t __attribute__ ((__mode__ (__HI__))); -# define _FPU_GETCW(cw) __asm__ ("fnstcw %0" : "=m" (*&cw)) -# define _FPU_SETCW(cw) __asm__ ("fldcw %0" : : "m" (*&cw)) +#define _FPU_GETCW(cw) __asm__ __volatile__ ("fnstcw %0" : "=m" (*&cw)) +#define _FPU_SETCW(cw) __asm__ __volatile__ ("fldcw %0" : : "m" (*&cw)) # define FPU_IEEE_ROUNDING 0x027f # define ADJUST_FPU_CONTROL_WORD #endif @@ -75,13 +82,26 @@ typedef unsigned int fpu_control_t __attribute__ ((__mode__ (__HI__))); # define NAN_MASK (((Tcl_WideUInt) 1) << 51) #endif -/* - * There now follows a lot of static variables that are shared across all - * threads but which are not guarded by mutexes. This is OK, because they are - * only ever assigned _ONCE_ during Tcl's library initialization sequence. - */ +/* The powers of ten that can be represented exactly as wide integers */ + +static int maxpow10_wide; +static Tcl_WideUInt *pow10_wide; + +/* The number of decimal digits that fit in an mp_digit */ + +static int log10_DIGIT_MAX; + +/* The powers of ten that can be represented exactly as IEEE754 doubles. */ + +#define MAXPOW 22 +static double pow10 [MAXPOW+1]; + +static int mmaxpow; /* Largest power of ten that can be + * represented exactly in a 'double'. */ -static const double pow_10_2_n[] = { /* Inexact higher powers of ten */ +/* Inexact higher powers of ten */ + +static CONST double pow_10_2_n [] = { 1.0, 100.0, 10000.0, @@ -92,440 +112,1414 @@ static const double pow_10_2_n[] = { /* Inexact higher powers of ten */ 1.0e+128, 1.0e+256 }; -#define MAXPOW 22 /* Num of exactly representable powers of 10 */ -static double pow10[MAXPOW+1]; /* The powers of ten that can be represented - * exactly as IEEE754 doubles. */ -static int mmaxpow; /* Largest power of ten that can be - * represented exactly in a 'double'. */ -static int log2FLT_RADIX; /* Logarithm of the floating point radix. */ -static int mantBits; /* Number of bits in a double's significand. */ -static mp_int pow5[9]; /* Table of powers of 5**(2**n), up to - * 5**256. */ -static double tiny; /* The smallest representable double. */ -static int maxDigits; /* The maximum number of digits to the left of - * the decimal point of a double. */ -static int minDigits; /* The maximum number of digits to the right - * of the decimal point in a double. */ -static int mantDIGIT; /* Number of mp_digit's needed to hold the - * significand of a double. */ + + /* Logarithm of the floating point radix. */ + +static int log2FLT_RADIX; + +/* Number of bits in a double's significand */ + +static int mantBits; + +/* Table of powers of 5**(2**n), up to 5**256 */ + +static mp_int pow5[9]; + +/* The smallest representable double */ + +static double tiny; + +/* The maximum number of digits to the left of the decimal point of a + * double. */ + +static int maxDigits; + +/* The maximum number of digits to the right of the decimal point in a + * double. */ + +static int minDigits; + +/* Number of mp_digit's needed to hold the significand of a double */ + +static int mantDIGIT; /* Static functions defined in this file */ -static double RefineResult(double approx, CONST char *start, int nDigits, - long exponent); -static double ParseNaN(int signum, CONST char **end); -static double SafeLdExp(double fraction, int exponent); +static int AccumulateDecimalDigit _ANSI_ARGS_((unsigned, int, + Tcl_WideUInt*, mp_int*, int)); +static double MakeLowPrecisionDouble _ANSI_ARGS_((int signum, + Tcl_WideUInt significand, + int nSigDigs, + int exponent)); +static double MakeHighPrecisionDouble _ANSI_ARGS_((int signum, + mp_int* significand, + int nSigDigs, + int exponent)); +static double MakeNaN _ANSI_ARGS_(( int signum, Tcl_WideUInt tag )); +static double RefineApproximation _ANSI_ARGS_((double approx, + mp_int* exactSignificand, + int exponent)); +static double AbsoluteValue(double v, int* signum); +static int GetIntegerTimesPower(double v, mp_int* r, int* e); +static double BignumToBiasedFrExp _ANSI_ARGS_(( mp_int* big, int* machexp )); +static double Pow10TimesFrExp _ANSI_ARGS_(( int exponent, + double fraction, + int* machexp )); +static double SafeLdExp _ANSI_ARGS_(( double fraction, int exponent )); + /* *---------------------------------------------------------------------- * - * TclStrToD -- + * TclParseNumber -- * - * Scans a double from a string. + * Place a "numeric" internal representation on a Tcl object. * * Results: - * Returns the scanned number. In the case of underflow, returns an - * appropriately signed zero; in the case of overflow, returns an - * appropriately signed HUGE_VAL. + * Returns a standard Tcl result. * * Side effects: - * Stores a pointer to the end of the scanned number in '*endPtr', if - * endPtr is not NULL. If '*endPtr' is equal to 's' on return from this - * function, it indicates that the input string could not be recognized - * as a number. In the case of underflow or overflow, 'errno' is set to - * ERANGE. + * Stores an internal representation appropriate to the string. + * The internal representation may be an integer, a wide integer, + * a bignum, or a double. + * + * TclMakeObjNumeric is called as a common scanner in routines + * that expect numbers in Tcl_Obj's. It scans the string representation + * of a given Tcl_Obj and stores an internal rep that represents + * a "canonical" version of its numeric value. The value of the + * canonicalization is that a routine can determine simply by + * examining the type pointer whether an object LooksLikeInt, + * what size of integer is needed to hold it, and similar questions, + * and never needs to refer back to the string representation, even + * for "impure" objects. + * + * The 'strPtr' and 'endPtrPtr' arguments allow for recognizing a number + * that is in a substring of a Tcl_Obj, for example a screen metric or + * "end-" index. If 'strPtr' is not NULL, it designates where the + * number begins within the string. (The default is the start of + * objPtr's string rep, which will be constructed if necessary.) * - *------------------------------------------------------------------------ + * If 'strPtr' is supplied, 'objPtr' may be NULL. In this case, + * no internal representation will be generated; instead, the routine + * will simply check for a syntactically correct number, returning + * TCL_OK or TCL_ERROR as appropriate, and setting *endPtrPtr if + * necessary. + * + * If 'endPtrPtr' is not NULL, it designates the first character + * after the scanned number. In this case, successfully recognizing + * any digits will yield a return code of TCL_OK. Only in the case + * where no leading string of 'strPtr' (or of objPtr's internal rep) + * represents a number will TCL_ERROR be returned. + * + * When only a partial string is being recognized, it is the caller's + * responsibility to destroy the internal representation, or at + * least change its type. Failure to do so will lead to subsequent + * problems where a string that does not represent a number will + * be recognized as one because it has a numeric internal representation. + * + * When the 'flags' word includes TCL_PARSE_DECIMAL_ONLY, only decimal + * numbers are recognized; leading 0 has no special interpretation as + * octal and leading '0x' is forbidden. + * + *---------------------------------------------------------------------- */ -double -TclStrToD(CONST char *s, /* String to scan. */ - CONST char **endPtr) /* Pointer to the end of the scanned number. */ +int +TclParseNumber( Tcl_Interp* interp, + /* Tcl interpreter for error reporting. + * May be NULL */ + Tcl_Obj* objPtr, + /* Object to receive the internal rep */ + CONST char* type, + /* Type of number being parsed ("integer", + * "wide integer", etc. */ + CONST char* string, + /* Pointer to the start of the string to + * scan, see above */ + size_t length, /* Maximum length of the string to scan, + * see above. */ + CONST char** endPtrPtr, + /* (Output) pointer to the end of the + * scanned number, see above */ + int flags) /* Flags governing the parse */ { - const char *p = s; - const char *startOfSignificand = NULL; - /* Start of the significand in the string. */ - int signum = 0; /* Sign of the significand. */ - double exactSignificand = 0.0; - /* Significand, represented exactly as a - * floating-point number. */ - int seenDigit = 0; /* Flag == 1 if a digit has been seen. */ - int nSigDigs = 0; /* Number of significant digits presented. */ - int nDigitsAfterDp = 0; /* Number of digits after the decimal point. */ - int nTrailZero = 0; /* Number of trailing zeros in the - * significand. */ - long exponent = 0; /* Exponent. */ - int seenDp = 0; /* Flag == 1 if decimal point has been seen. */ - char c; /* One character extracted from the input. */ - volatile double v; /* Scanned value; must be 'volatile double' on - * gc-ix86 to force correct rounding to IEEE - * double and not Intel double-extended. */ - int machexp; /* Exponent of the machine rep of the scanned - * value. */ - int expt2; /* Exponent for computing first approximation - * to the true value. */ - int i, j; - /* - * With gcc on x86, the floating point rounding mode is double-extended. - * This causes the result of double-precision calculations to be rounded - * twice: once to the precision of double-extended and then again to the - * precision of double. Double-rounding introduces gratuitous errors of - * one ulp, so we need to change rounding mode to 53-bits. - */ - -#ifdef ADJUST_FPU_CONTROL_WORD - fpu_control_t roundTo53Bits = FPU_IEEE_ROUNDING; - fpu_control_t oldRoundingMode; - _FPU_GETCW(oldRoundingMode); - _FPU_SETCW(roundTo53Bits); -# define RestoreRoundingMode() _FPU_SETCW(oldRoundingMode) -#else -# define RestoreRoundingMode() (void) 0 /* Do nothing */ + enum State { + INITIAL, SIGNUM, ZERO, ZERO_X, +#ifdef TIP_114_FORMATS + ZERO_O, ZERO_B, BINARY, +#endif + HEXADECIMAL, OCTAL, BAD_OCTAL, DECIMAL, + LEADING_RADIX_POINT, FRACTION, + EXPONENT_START, EXPONENT_SIGNUM, EXPONENT, + sI, sIN, sINF, sINFI, sINFIN, sINFINI, sINFINIT, sINFINITY +#ifdef IEEE_FLOATING_POINT + , sN, sNA, sNAN, sNANPAREN, sNANHEX, sNANFINISH +#endif + } state = INITIAL; + enum State acceptState = INITIAL; + + int signum = 0; /* Sign of the number being parsed */ + Tcl_WideUInt significandWide = 0; + /* Significand of the number being + * parsed (if no overflow) */ + mp_int significandBig; /* Significand of the number being + * parsed (if it overflows significandWide) */ + int significandOverflow = 0; + /* Flag==1 iff significandBig is used */ + Tcl_WideUInt octalSignificandWide = 0; + /* Significand of an octal number; needed + * because we don't know whether a number + * with a leading zero is octal or decimal + * until we've scanned forward to a '.' or + * 'e' */ + mp_int octalSignificandBig; /* Significand of octal number once + * octalSignificandWide overflows */ + int octalSignificandOverflow = 0; + /* Flag==1 if octalSignificandBig is used */ + int numSigDigs = 0; /* Number of significant digits in the + * decimal significand */ + int numTrailZeros = 0; /* Number of trailing zeroes at the + * current point in the parse. */ + int numDigitsAfterDp = 0; /* Number of digits scanned after the + * decimal point */ + int exponentSignum = 0; /* Signum of the exponent of a floating + * point number */ + long exponent = 0; /* Exponent of a floating point number */ + CONST char* p; /* Pointer to next character to scan */ + size_t len; /* Number of characters remaining after p */ + CONST char* acceptPoint; /* Pointer to position after last character + * in an acceptable number */ + size_t acceptLen; /* Number of characters following that point */ + int status = TCL_OK; /* Status to return to caller */ + char d; /* Last hexadecimal digit scanned */ + int shift = 0; /* Amount to shift when accumulating binary */ +#ifdef TIP_114_FORMATS + int explicitOctal = 0; #endif - /* - * Discard leading whitespace from input. + /* + * Initialize string to start of the object's string rep if + * the caller didn't pass anything else. */ - while (isspace(UCHAR(*p))) { - ++p; + if ( string == NULL ) { + string = Tcl_GetStringFromObj( objPtr, NULL ); } - /* - * Determine the sign of the significand. - */ + p = string; + len = length; + acceptPoint = p; + acceptLen = len; + while ( 1 ) { + char c = len ? *p : '\0'; + switch (state) { - switch (*p) { - case '-': - signum = 1; + case INITIAL: + /* + * Initial state. Acceptable characters are +, -, digits, + * period, I, N, and whitespace. + */ + if (isspace(UCHAR(c))) { + break; + } else if (c == '+') { + state = SIGNUM; + break; + } else if (c == '-') { + signum = 1; + state = SIGNUM; + break; + } /* FALLTHROUGH */ - case '+': - ++p; - } - - /* - * Discard leading zeroes from input. - */ + + case SIGNUM: + /* + * Scanned a leading + or -. Acceptable characters are + * digits, period, I, and N. + */ + if (c == '0') { + if (flags & TCL_PARSE_DECIMAL_ONLY) { + state = DECIMAL; + } else { + state = ZERO; + } + break; + } else if (flags & TCL_PARSE_HEXADECIMAL_ONLY) { + goto zerox; + } else if (flags & TCL_PARSE_OCTAL_ONLY) { + goto zeroo; + } else if (isdigit(UCHAR(c))) { + significandWide = c - '0'; + numSigDigs = 1; + state = DECIMAL; + break; + } else if (flags & TCL_PARSE_INTEGER_ONLY) { + goto endgame; + } else if (c == '.') { + state = LEADING_RADIX_POINT; + break; + } else if (c == 'I' || c == 'i') { + state = sI; + break; +#ifdef IEEE_FLOATING_POINT + } else if (c == 'N' || c == 'n') { + state = sN; + break; +#endif + } + goto endgame; - while (*p == '0') { - seenDigit = 1; - ++p; - } + case ZERO: + /* + * Scanned a leading zero (perhaps with a + or -). + * Acceptable inputs are digits, period, X, and E. + * If 8 or 9 is encountered, the number can't be + * octal. This state and the OCTAL state differ only + * in whether they recognize 'X'. + */ + acceptState = state; + acceptPoint = p; + acceptLen = len; + if (c == 'x' || c == 'X') { + state = ZERO_X; + break; + } + if (flags & TCL_PARSE_HEXADECIMAL_ONLY) { + goto zerox; + } +#ifdef TIP_114_FORMATS + if (flags & TCL_PARSE_SCAN_PREFIXES) { + goto zeroo; + } + if (c == 'b' || c == 'B') { + state = ZERO_B; + break; + } + if (c == 'o' || c == 'O') { + explicitOctal = 1; + state = ZERO_O; + break; + } +#ifdef KILL_OCTAL + goto decimal; +#endif +#endif + /* FALLTHROUGH */ - /* - * Scan digits from the significand. Simultaneously, keep track of the - * number of digits after the decimal point. Maintain a pointer to the - * start of the significand. Keep "exactSignificand" equal to the - * conversion of the DBL_DIG most significant digits. - */ + case OCTAL: + /* + * Scanned an optional + or -, followed by a string of + * octal digits. Acceptable inputs are more digits, + * period, or E. If 8 or 9 is encountered, commit to + * floating point. + */ + acceptState = state; + acceptPoint = p; + acceptLen = len; +#ifdef TIP_114_FORMATS + /* FALLTHROUGH */ + case ZERO_O: +#endif + zeroo: + if (c == '0') { + ++numTrailZeros; + state = OCTAL; + break; + } else if (c >= '1' && c <= '7') { + if (objPtr != NULL) { + shift = 3 * (numTrailZeros + 1); + significandOverflow = + AccumulateDecimalDigit((unsigned)(c-'0'), + numTrailZeros, + &significandWide, + &significandBig, + significandOverflow); + + if (!octalSignificandOverflow) { + /* + * Shifting by more bits than are in the value being + * shifted is at least de facto nonportable. Check + * for too large shifts first. + */ + if ((octalSignificandWide != 0) + && ((shift >= CHAR_BIT*sizeof(Tcl_WideUInt)) + || (octalSignificandWide + > (~(Tcl_WideUInt)0 >> shift)))) { + octalSignificandOverflow = 1; + TclBNInitBignumFromWideUInt(&octalSignificandBig, + octalSignificandWide); + } + } + if (!octalSignificandOverflow) { + octalSignificandWide + = (octalSignificandWide << shift) + (c - '0'); + } else { + mp_mul_2d(&octalSignificandBig, shift, + &octalSignificandBig); + mp_add_d(&octalSignificandBig, (mp_digit)(c - '0'), + &octalSignificandBig); + } + } + if ( numSigDigs != 0 ) { + numSigDigs += ( numTrailZeros + 1 ); + } else { + numSigDigs = 1; + } + numTrailZeros = 0; + state = OCTAL; + break; + } + /* FALLTHROUGH */ - for (;;) { - c = *p; - if (c == '.' && !seenDp) { - seenDp = 1; - ++p; - } else if (isdigit(UCHAR(c))) { + case BAD_OCTAL: +#ifdef TIP_114_FORMATS + if (explicitOctal) { + /* No forgiveness for bad digits in explicitly octal numbers */ + goto endgame; + } +#endif + if (flags & TCL_PARSE_INTEGER_ONLY) { + /* No seeking floating point when parsing only integer */ + goto endgame; + } +#ifndef KILL_OCTAL + /* + * Scanned a number with a leading zero that contains an + * 8, 9, radix point or E. This is an invalid octal number, + * but might still be floating point. + */ if (c == '0') { - if (startOfSignificand != NULL) { - ++nTrailZero; + ++numTrailZeros; + state = BAD_OCTAL; + break; + } else if (isdigit(UCHAR(c))) { + if (objPtr != NULL) { + significandOverflow = + AccumulateDecimalDigit((unsigned)(c-'0'), + numTrailZeros, + &significandWide, + &significandBig, + significandOverflow); + } + if ( numSigDigs != 0 ) { + numSigDigs += ( numTrailZeros + 1 ); + } else { + numSigDigs = 1; } + numTrailZeros = 0; + state = BAD_OCTAL; + break; + } else if (c == '.') { + state = FRACTION; + break; + } else if (c == 'E' || c == 'e') { + state = EXPONENT_START; + break; + } +#endif + goto endgame; + + /* + * Scanned 0x. If state is HEXADECIMAL, scanned at least + * one character following the 0x. The only acceptable + * inputs are hexadecimal digits. + */ + case HEXADECIMAL: + acceptState = state; + acceptPoint = p; + acceptLen = len; + /* FALLTHROUGH */ + case ZERO_X: + zerox: + if (c == '0') { + ++numTrailZeros; + state = HEXADECIMAL; + break; + } else if (isdigit(UCHAR(c))) { + d = (c-'0'); + } else if (c >= 'A' && c <= 'F') { + d = (c-'A'+10); + } else if (c >= 'a' && c <= 'f') { + d = (c-'a'+10); } else { - if (startOfSignificand == NULL) { - startOfSignificand = p; - } else if (nTrailZero) { - if (nTrailZero + nSigDigs < DBL_DIG) { - exactSignificand *= pow10[nTrailZero]; - } else if (nSigDigs < DBL_DIG) { - exactSignificand *= pow10[DBL_DIG - nSigDigs]; + goto endgame; + } + if (objPtr != NULL) { + shift = 4 * (numTrailZeros + 1); + if (!significandOverflow) { + /* + * Shifting by more bits than are in the value being + * shifted is at least de facto nonportable. Check + * for too large shifts first. + */ + if (significandWide != 0 + && (shift >= CHAR_BIT*sizeof(Tcl_WideUInt) + || significandWide > (~(Tcl_WideUInt)0 >> shift))) { + significandOverflow = 1; + TclBNInitBignumFromWideUInt(&significandBig, + significandWide); } - nSigDigs += nTrailZero; } - if (nSigDigs < DBL_DIG) { - exactSignificand = 10. * exactSignificand + (c - '0'); + if (!significandOverflow) { + significandWide + = (significandWide << shift) + d; + } else { + mp_mul_2d(&significandBig, shift, + &significandBig); + mp_add_d(&significandBig, (mp_digit) d, + &significandBig); } - ++nSigDigs; - nTrailZero = 0; } - if (seenDp) { - ++nDigitsAfterDp; + numTrailZeros = 0; + state = HEXADECIMAL; + break; + +#ifdef TIP_114_FORMATS + case BINARY: + acceptState = state; + acceptPoint = p; + acceptLen = len; + case ZERO_B: + if (c == '0') { + ++numTrailZeros; + state = BINARY; + break; + } else if (c != '1') { + goto endgame; } - seenDigit = 1; - ++p; - } else { + if (objPtr != NULL) { + shift = numTrailZeros + 1; + if (!significandOverflow) { + /* + * Shifting by more bits than are in the value being + * shifted is at least de facto nonportable. Check + * for too large shifts first. + */ + if (significandWide != 0 + && (shift >= CHAR_BIT*sizeof(Tcl_WideUInt) + || significandWide > (~(Tcl_WideUInt)0 >> shift))) { + significandOverflow = 1; + TclBNInitBignumFromWideUInt(&significandBig, + significandWide); + } + } + if (!significandOverflow) { + significandWide + = (significandWide << shift) + 1; + } else { + mp_mul_2d(&significandBig, shift, + &significandBig); + mp_add_d(&significandBig, (mp_digit) 1, + &significandBig); + } + } + numTrailZeros = 0; + state = BINARY; break; - } - } +#endif - /* - * At this point, we've scanned the significand, and p points to the - * character beyond it. "startOfSignificand" is the first non-zero - * character in the significand. "nSigDigs" is the number of significant - * digits of the significand, not including any trailing zeroes. - * "exactSignificand" is a floating point number that represents, without - * loss of precision, the first min(DBL_DIG,n) digits of the significand. - * "nDigitsAfterDp" is the number of digits after the decimal point, again - * excluding trailing zeroes. - * - * Now scan 'E' format - */ + case DECIMAL: + /* + * Scanned an optional + or - followed by a string of + * decimal digits. + */ +#ifdef KILL_OCTAL + decimal: +#endif + acceptState = state; + acceptPoint = p; + acceptLen = len; + if (c == '0') { + ++numTrailZeros; + state = DECIMAL; + break; + } else if (isdigit(UCHAR(c))) { + if (objPtr != NULL) { + significandOverflow = + AccumulateDecimalDigit((unsigned)(c - '0'), + numTrailZeros, + &significandWide, + &significandBig, + significandOverflow); + } + numSigDigs += ( numTrailZeros + 1 ); + numTrailZeros = 0; + state = DECIMAL; + break; + } else if (flags & TCL_PARSE_INTEGER_ONLY) { + goto endgame; + } else if (c == '.') { + state = FRACTION; + break; + } else if (c == 'E' || c == 'e') { + state = EXPONENT_START; + break; + } + goto endgame; - exponent = 0; - if (seenDigit && (*p == 'e' || *p == 'E')) { - const char* stringSave = p; - ++p; - c = *p; - if (isdigit(UCHAR(c)) || c == '+' || c == '-') { - errno = 0; - exponent = strtol(p, (char**)&p, 10); - if (errno == ERANGE) { - if (exponent > 0) { - v = HUGE_VAL; + /* + * Found a decimal point. If no digits have yet been scanned, + * E is not allowed; otherwise, it introduces the exponent. + * If at least one digit has been found, we have a possible + * complete number. + */ + case FRACTION: + acceptState = state; + acceptPoint = p; + acceptLen = len; + if (c == 'E' || c=='e') { + state = EXPONENT_START; + break; + } + /* FALLTHROUGH */ + case LEADING_RADIX_POINT: + if (c == '0') { + ++numDigitsAfterDp; + ++numTrailZeros; + state = FRACTION; + break; + } else if (isdigit(UCHAR(c))) { + ++numDigitsAfterDp; + if (objPtr != NULL) { + significandOverflow = + AccumulateDecimalDigit((unsigned)(c-'0'), + numTrailZeros, + &significandWide, + &significandBig, + significandOverflow); + } + if ( numSigDigs != 0 ) { + numSigDigs += ( numTrailZeros + 1 ); } else { - v = 0.0; + numSigDigs = 1; } - *endPtr = p; - goto returnValue; + numTrailZeros = 0; + state = FRACTION; + break; } - } - if (p == stringSave+1) { - p = stringSave; - exponent = 0; - } - } - exponent += nTrailZero - nDigitsAfterDp; + goto endgame; - /* - * If we come here with no significant digits, we might still be looking - * at Inf or NaN. Go parse them. - */ + case EXPONENT_START: + /* + * Scanned the E at the start of an exponent. Make sure + * a legal character follows before using the C library + * strtol routine, which allows whitespace. + */ + if (c == '+') { + state = EXPONENT_SIGNUM; + break; + } else if (c == '-') { + exponentSignum = 1; + state = EXPONENT_SIGNUM; + break; + } + /* FALLTHROUGH */ - if (!seenDigit) { - /* - * Test for Inf or Infinity (in any case). - */ + case EXPONENT_SIGNUM: + /* + * Found the E at the start of the exponent, followed by + * a sign character. + */ + if (isdigit(UCHAR(c))) { + exponent = c - '0'; + state = EXPONENT; + break; + } + goto endgame; - if (c == 'I' || c == 'i') { - if ((p[1] == 'N' || p[1] == 'n') - && (p[2] == 'F' || p[2] == 'f')) { - p += 3; - if ((p[0] == 'I' || p[0] == 'i') - && (p[1] == 'N' || p[1] == 'n') - && (p[2] == 'I' || p[2] == 'i') - && (p[3] == 'T' || p[3] == 't') - && (p[4] == 'Y' || p[1] == 'y')) { - p += 5; - } - errno = ERANGE; - v = HUGE_VAL; - if (endPtr != NULL) { - *endPtr = p; + case EXPONENT: + /* + * Found an exponent with at least one digit. + * Accumulate it, making sure to hard-pin it to LONG_MAX + * on overflow. + */ + acceptState = state; + acceptPoint = p; + acceptLen = len; + if (isdigit(UCHAR(c))) { + if (exponent < (LONG_MAX - 9) / 10) { + exponent = 10 * exponent + (c - '0'); + } else { + exponent = LONG_MAX; } - goto returnValue; + state = EXPONENT; + break; } + goto endgame; -#ifdef IEEE_FLOATING_POINT /* - * Only IEEE floating point supports NaN + * Parse out INFINITY by simply spelling it out. + * INF is accepted as an abbreviation; other prefices are + * not. */ - } else if ((c == 'N' || c == 'n') - && (sizeof(Tcl_WideUInt) == sizeof(double))) { - if ((p[1] == 'A' || p[1] == 'a') - && (p[2] == 'N' || p[2] == 'n')) { - p += 3; - - if (endPtr != NULL) { - *endPtr = p; - } + case sI: + if ( c == 'n' || c == 'N' ) { + state = sIN; + break; + } + goto endgame; + case sIN: + if ( c == 'f' || c == 'F' ) { + state = sINF; + break; + } + goto endgame; + case sINF: + acceptState = state; + acceptPoint = p; + acceptLen = len; + if ( c == 'i' || c == 'I' ) { + state = sINFI; + break; + } + goto endgame; + case sINFI: + if ( c == 'n' || c == 'N' ) { + state = sINFIN; + break; + } + goto endgame; + case sINFIN: + if ( c == 'i' || c == 'I' ) { + state = sINFINI; + break; + } + goto endgame; + case sINFINI: + if ( c == 't' || c == 'T' ) { + state = sINFINIT; + break; + } + goto endgame; + case sINFINIT: + if ( c == 'y' || c == 'Y' ) { + state = sINFINITY; + break; + } + goto endgame; - /* - * Restore FPU mode word. - */ + /* + * Parse NaN's. + */ +#ifdef IEEE_FLOATING_POINT + case sN: + if ( c == 'a' || c == 'A' ) { + state = sNA; + break; + } + goto endgame; + case sNA: + if ( c == 'n' || c == 'N' ) { + state = sNAN; + break; + } + case sNAN: + acceptState = state; + acceptPoint = p; + acceptLen = len; + if ( c == '(' ) { + state = sNANPAREN; + break; + } + goto endgame; - RestoreRoundingMode(); - return ParseNaN(signum, endPtr); + /* + * Parse NaN(hexdigits) + */ + case sNANHEX: + if ( c == ')' ) { + state = sNANFINISH; + break; } + /* FALLTHROUGH */ + case sNANPAREN: + if ( isspace(UCHAR(c)) ) { + break; + } + if ( numSigDigs < 13 ) { + if ( c >= '0' && c <= '9' ) { + d = c - '0'; + } else if ( c >= 'a' && c <= 'f' ) { + d = 10 + c - 'a'; + } else if ( c >= 'A' && c <= 'F' ) { + d = 10 + c - 'A'; + } + significandWide = (significandWide << 4) + d; + state = sNANHEX; + break; + } + goto endgame; + case sNANFINISH: #endif + case sINFINITY: + acceptState = state; + acceptPoint = p; + acceptLen = len; + goto endgame; } + ++p; + --len; + } + + endgame: - goto error; + /* Back up to the last accepting state in the lexer */ + + if (acceptState == INITIAL) { + status = TCL_ERROR; } + p = acceptPoint; + len = acceptLen; - /* - * We've successfully scanned; update the end-of-element pointer. - */ + /* Skip past trailing whitespace */ - if (endPtr != NULL) { - *endPtr = p; + if (endPtrPtr != NULL) { + *endPtrPtr = p; } - /* - * Test for zero. - */ + while (len > 0 && isspace(UCHAR(*p))) { + ++p; + --len; + } - if (nSigDigs == 0) { - v = 0.0; - goto returnValue; + /* Determine whether a partial string is acceptable. */ + + if (endPtrPtr == NULL && len != 0 && *p != '\0') { + status = TCL_ERROR; } - /* - * The easy cases are where we have an exact significand and the exponent - * is small enough that we can compute the value with only one roundoff. - * In addition to the cases where we can multiply or divide an - * exact-integer significand by an exact-integer power of 10, there is - * also David Gay's case where we can scale the significand by a power of - * 10 (still keeping it exact) and then multiply by an exact power of 10. - * The last case enables combinations like 83e25 that would otherwise - * require high precision arithmetic. - */ + /* Generate and store the appropriate internal rep */ - if (nSigDigs <= DBL_DIG) { - if (exponent >= 0) { - if (exponent <= mmaxpow) { - v = exactSignificand * pow10[exponent]; - goto returnValue; - } else { - int diff = DBL_DIG - nSigDigs; - if (exponent - diff <= mmaxpow) { - volatile double factor = exactSignificand * pow10[diff]; - v = factor * pow10[exponent - diff]; - goto returnValue; + if (status == TCL_OK && objPtr != NULL) { + if ( acceptState != INITIAL ) { + TclFreeIntRep( objPtr ); + } + switch (acceptState) { + + case INITIAL: + status = TCL_ERROR; + break; + + case SIGNUM: + case BAD_OCTAL: + case ZERO_X: +#ifdef TIP_114_FORMATS + case ZERO_O: + case ZERO_B: +#endif + case LEADING_RADIX_POINT: + case EXPONENT_START: + case EXPONENT_SIGNUM: + case sI: + case sIN: + case sINFI: + case sINFIN: + case sINFINI: + case sINFINIT: + case sN: + case sNA: + case sNANPAREN: + case sNANHEX: + panic("in TclParseNumber: bad acceptState, can't happen."); + +#ifdef TIP_114_FORMATS + case BINARY: + shift = numTrailZeros; + if (!significandOverflow) { + if (significandWide !=0 + && (shift >= CHAR_BIT*sizeof(Tcl_WideUInt) + || significandWide + > (((~(Tcl_WideUInt)0) >> 1) + signum) >> shift )) { + significandOverflow = 1; + TclBNInitBignumFromWideUInt(&significandBig, + significandWide); } } - } else if (exponent >= -mmaxpow) { - v = exactSignificand / pow10[-exponent]; - goto returnValue; + if (shift) { + if ( !significandOverflow ) { + significandWide <<= shift; + } else { + mp_mul_2d( &significandBig, shift, &significandBig ); + } + } + goto returnInteger; +#endif + case HEXADECIMAL: + /* Returning a hex integer. Final scaling step */ + shift = 4 * numTrailZeros; + if (!significandOverflow) { + if (significandWide !=0 + && (shift >= CHAR_BIT*sizeof(Tcl_WideUInt) + || significandWide + > (((~(Tcl_WideUInt)0) >> 1) + signum) >> shift )) { + significandOverflow = 1; + TclBNInitBignumFromWideUInt(&significandBig, + significandWide); + } + } + if (shift) { + if ( !significandOverflow ) { + significandWide <<= shift; + } else { + mp_mul_2d( &significandBig, shift, &significandBig ); + } + } + goto returnInteger; + + case OCTAL: + /* Returning an octal integer. Final scaling step */ + shift = 3 * numTrailZeros; + if (!octalSignificandOverflow) { + if (octalSignificandWide != 0 + && (shift >= CHAR_BIT*sizeof(Tcl_WideUInt) + || octalSignificandWide + > (((~(Tcl_WideUInt)0) >> 1) + signum) >> shift )) { + octalSignificandOverflow = 1; + TclBNInitBignumFromWideUInt(&octalSignificandBig, + octalSignificandWide); + } + } + if ( shift ) { + if ( !octalSignificandOverflow ) { + octalSignificandWide <<= shift; + } else { + mp_mul_2d( &octalSignificandBig, shift, + &octalSignificandBig ); + } + } + if (!octalSignificandOverflow) { + if (octalSignificandWide > + (Tcl_WideUInt)(((~(unsigned long)0) >> 1) + signum)) { +#ifndef NO_WIDE_TYPE + if (octalSignificandWide + <= (((~(Tcl_WideUInt)0) >> 1) + signum)) { + objPtr->typePtr = &tclWideIntType; + if (signum) { + objPtr->internalRep.wideValue = + - (Tcl_WideInt) octalSignificandWide; + } else { + objPtr->internalRep.wideValue = + (Tcl_WideInt) octalSignificandWide; + } + break; + } +#endif + TclBNInitBignumFromWideUInt(&octalSignificandBig, + octalSignificandWide); + octalSignificandOverflow = 1; + } else { + objPtr->typePtr = &tclIntType; + if (signum) { + objPtr->internalRep.longValue = + - (long) octalSignificandWide; + } else { + objPtr->internalRep.longValue = + (long) octalSignificandWide; + } + } + } + if (octalSignificandOverflow) { + if (signum) { + mp_neg(&octalSignificandBig, &octalSignificandBig); + } + TclSetBignumIntRep(objPtr, &octalSignificandBig); + } + break; + + case ZERO: + case DECIMAL: + significandOverflow = + AccumulateDecimalDigit( 0, numTrailZeros-1, + &significandWide, &significandBig, + significandOverflow ); + if (!significandOverflow + && (significandWide + > (((~(Tcl_WideUInt)0) >> 1) + signum))) { + significandOverflow = 1; + TclBNInitBignumFromWideUInt(&significandBig, + significandWide); + } + returnInteger: + if (!significandOverflow) { + if (significandWide > + (Tcl_WideUInt)(((~(unsigned long)0) >> 1) + signum)) { +#ifndef NO_WIDE_TYPE + if (significandWide + <= (((~(Tcl_WideUInt)0) >> 1) + signum)) { + objPtr->typePtr = &tclWideIntType; + if (signum) { + objPtr->internalRep.wideValue = + - (Tcl_WideInt) significandWide; + } else { + objPtr->internalRep.wideValue = + (Tcl_WideInt) significandWide; + } + break; + } +#endif + TclBNInitBignumFromWideUInt(&significandBig, + significandWide); + significandOverflow = 1; + } else { + objPtr->typePtr = &tclIntType; + if (signum) { + objPtr->internalRep.longValue = + - (long) significandWide; + } else { + objPtr->internalRep.longValue = + (long) significandWide; + } + } + } + if (significandOverflow) { + if (signum) { + mp_neg(&significandBig, &significandBig); + } + TclSetBignumIntRep(objPtr, &significandBig); + } + break; + + case FRACTION: + case EXPONENT: + + /* + * Here, we're parsing a floating-point number. + * 'significandWide' or 'significandBig' contains the + * exact significand, according to whether + * 'significandOverflow' is set. The desired floating + * point value is significand * 10**k, where + * k = numTrailZeros+exponent-numDigitsAfterDp. + */ + + objPtr->typePtr = &tclDoubleType; + if ( exponentSignum ) { + exponent = - exponent; + } + if ( !significandOverflow ) { + objPtr->internalRep.doubleValue = + MakeLowPrecisionDouble( signum, + significandWide, + numSigDigs, + ( numTrailZeros + + exponent + - numDigitsAfterDp ) ); + } else { + objPtr->internalRep.doubleValue = + MakeHighPrecisionDouble( signum, + &significandBig, + numSigDigs, + ( numTrailZeros + + exponent + - numDigitsAfterDp ) ); + } + break; + + case sINF: + case sINFINITY: + if ( signum ) { + objPtr->internalRep.doubleValue = -HUGE_VAL; + } else { + objPtr->internalRep.doubleValue = HUGE_VAL; + } + objPtr->typePtr = &tclDoubleType; + break; + + case sNAN: + case sNANFINISH: + objPtr->internalRep.doubleValue + = MakeNaN( signum, significandWide ); + objPtr->typePtr = &tclDoubleType; + break; + } } - /* - * We don't have one of the easy cases, so we can't compute the scanned - * number exactly, and have to do it in multiple precision. Begin by - * testing for obvious overflows and underflows. - */ + /* Format an error message when an invalid number is encountered. */ + + if ( status != TCL_OK ) { + if ( interp != NULL ) { + Tcl_Obj *msg = Tcl_NewStringObj( "expected ", -1 ); + Tcl_AppendToObj( msg, type, -1 ); + Tcl_AppendToObj( msg, " but got \"", -1 ); + TclAppendLimitedToObj( msg, string, length, 50, "" ); + Tcl_AppendToObj( msg, "\"", -1 ); + if ( state == BAD_OCTAL ) { + Tcl_AppendToObj( msg, " (looks like invalid octal number)", + -1 ); + } + Tcl_SetObjResult( interp, msg ); + } + } - if (nSigDigs + exponent - 1 > maxDigits) { - v = HUGE_VAL; - errno = ERANGE; - goto returnValue; + /* Free memory */ + + if (octalSignificandOverflow) { + mp_clear(&octalSignificandBig); } - if (nSigDigs + exponent - 1 < minDigits) { - errno = ERANGE; - v = 0.; - goto returnValue; + if (significandOverflow) { + mp_clear(&significandBig); } + return status; +} + +/* + *---------------------------------------------------------------------- + * + * AccumulateDecimalDigit -- + * + * Consume a decimal digit in a number being scanned. + * + * Results: + * Returns 1 if the number has overflowed to a bignum, 0 if it + * still fits in a wide integer. + * + * Side effects: + * Updates either the wide or bignum representation. + * + *---------------------------------------------------------------------- + */ - /* - * Nothing exceeds the boundaries of the tables, at least. Compute an - * approximate value for the number, with no possibility of overflow - * because we manage the exponent separately. - */ - - if (nSigDigs > DBL_DIG) { - expt2 = exponent + nSigDigs - DBL_DIG; - } else { - expt2 = exponent; - } - v = frexp(exactSignificand, &machexp); - if (expt2 > 0) { - v = frexp(v * pow10[expt2 & 0xf], &j); - machexp += j; - for (i=4 ; i<9 ; ++i) { - if (expt2 & (1 << i)) { - v = frexp(v * pow_10_2_n[i], &j); - machexp += j; +static int +AccumulateDecimalDigit( unsigned digit, + /* Digit being scanned */ + int numZeros, + /* Count of zero digits preceding the + * digit being scanned */ + Tcl_WideUInt* wideRepPtr, + /* Representation of the partial number + * as a wide integer */ + mp_int* bignumRepPtr, + /* Representation of the partial number + * as a bignum */ + int bignumFlag ) + /* Flag == 1 if the number overflowed + * previous to this digit. */ +{ + int i, n; + + /* Check if the number still fits in a wide */ + + if (!bignumFlag) { + if (*wideRepPtr != 0) { + if ((numZeros >= maxpow10_wide) + || (*wideRepPtr > (((~(Tcl_WideUInt)0) - digit) + / pow10_wide[numZeros+1]))) { + /* Oops, it's overflowed, have to allocate a bignum */ + TclBNInitBignumFromWideUInt (bignumRepPtr, *wideRepPtr); + bignumFlag = 1; } } + } + + /* Multiply the number by 10**numZeros+1 and add in the new digit. */ + + if (!bignumFlag) { + + /* Wide multiplication */ + + *wideRepPtr = *wideRepPtr * pow10_wide[numZeros+1] + digit; + } else if (numZeros < log10_DIGIT_MAX ) { + + /* Up to about 8 zeros - single digit multiplication */ + + mp_mul_d (bignumRepPtr, (mp_digit) pow10_wide[numZeros+1], + bignumRepPtr); + mp_add_d (bignumRepPtr, (mp_digit) digit, bignumRepPtr); + } else { - v = frexp(v / pow10[(-expt2) & 0xf], &j); - machexp += j; - for (i=4 ; i<9 ; ++i) { - if ((-expt2) & (1 << i)) { - v = frexp(v / pow_10_2_n[i], &j); - machexp += j; + + /* + * More than single digit multiplication. Multiply by the appropriate + * small powers of 5, and then shift. Large strings of zeroes are + * eaten 256 at a time; this is less efficient than it could be, + * but seems implausible. We presume that DIGIT_BIT is at least 27. + * The first multiplication, by up to 10**7, is done with a + * one-DIGIT multiply (this presumes that DIGIT_BIT >= 24). + */ + + n = numZeros + 1; + mp_mul_d (bignumRepPtr, (mp_digit) pow10_wide[n&0x7], bignumRepPtr); + for (i = 3; i <= 7; ++i) { + if (n & (1 << i)) { + mp_mul (bignumRepPtr, pow5+i, bignumRepPtr); } } + while (n >= 256) { + mp_mul (bignumRepPtr, pow5+8, bignumRepPtr); + n -= 256; + } + mp_mul_2d (bignumRepPtr, (int)(numZeros+1)&~0x7, bignumRepPtr); } + return bignumFlag; +} + +/* + *---------------------------------------------------------------------- + * + * MakeLowPrecisionDouble -- + * + * Makes the double precision number, signum*significand*10**exponent. + * + * Results: + * Returns the constructed number. + * + * Common cases, where there are few enough digits that the number can + * be represented with at most roundoff, are handled specially here. + * If the number requires more than one rounded operation to compute, + * the code promotes the significand to a bignum and calls + * MakeHighPrecisionDouble to do it instead. + * + *---------------------------------------------------------------------- + */ + +static double +MakeLowPrecisionDouble( int signum, + /* 1 if the number is negative, 0 otherwise */ + Tcl_WideUInt significand, + /* Significand of the number */ + int numSigDigs, + /* Number of digits in the significand */ + int exponent ) + /* Power of ten */ +{ + double retval; /* Value of the number */ + mp_int significandBig; /* Significand expressed as a bignum */ + /* - * A first approximation is that the result will be v * 2 ** machexp. v is - * greater than or equal to 0.5 and less than 1. If machexp > - * DBL_MAX_EXP*log2(FLT_RADIX), there is an overflow. Constrain the result - * to the smallest representible number to avoid premature underflow. + * With gcc on x86, the floating point rounding mode is double-extended. + * This causes the result of double-precision calculations to be rounded + * twice: once to the precision of double-extended and then again to the + * precision of double. Double-rounding introduces gratuitous errors of + * 1 ulp, so we need to change rounding mode to 53-bits. */ - if (machexp > DBL_MAX_EXP * log2FLT_RADIX) { - v = HUGE_VAL; - errno = ERANGE; - goto returnValue; - } +#if defined(__GNUC__) && defined(__i386) + fpu_control_t roundTo53Bits = 0x027f; + fpu_control_t oldRoundingMode; + _FPU_GETCW( oldRoundingMode ); + _FPU_SETCW( roundTo53Bits ); +#endif - v = SafeLdExp(v, machexp); - if (v < tiny) { - v = tiny; - } + /* Test for the easy cases */ - /* - * We have a first approximation in v. Now we need to refine it. - */ + if ( numSigDigs <= DBL_DIG ) { + if ( exponent >= 0 ) { + if ( exponent <= mmaxpow ) { - v = RefineResult(v, startOfSignificand, nSigDigs, exponent); + /* + * The significand is an exact integer, and so is + * 10**exponent. The product will be correct to within + * 1/2 ulp without special handling. + */ - /* - * In a very few cases, a second iteration is needed. e.g., 457e-102 - */ + retval = (double)(Tcl_WideInt)significand * pow10[ exponent ]; + goto returnValue; - v = RefineResult(v, startOfSignificand, nSigDigs, exponent); + } else { + int diff = DBL_DIG - numSigDigs; + if ( exponent-diff <= mmaxpow ) { + + /* + * 10**exponent is not an exact integer, but + * 10**(exponent-diff) is exact, and so is + * significand*10**diff, so we can still compute + * the value with only one roundoff. + */ + volatile double factor + = (double)(Tcl_WideInt)significand * pow10[diff]; + retval = factor * pow10[exponent-diff]; + goto returnValue; + } + } + } else { + if ( exponent >= -mmaxpow ) { + + /* + * 10**-exponent is an exact integer, and so is the + * significand. Compute the result by one division, + * again with only one rounding. + */ + + retval = (double)(Tcl_WideInt)significand / pow10[-exponent]; + goto returnValue; + } + } + } /* - * Handle underflow. + * All the easy cases have failed. Promote ths significand + * to bignum and call MakeHighPrecisionDouble to do it the hard way. */ + TclBNInitBignumFromWideUInt (&significandBig, significand); + retval = MakeHighPrecisionDouble( 0, &significandBig, numSigDigs, + exponent ); + + /* Come here to return the computed value */ + returnValue: - if (nSigDigs != 0 && v == 0.0) { - errno = ERANGE; + + if ( signum ) { + retval = -retval; } + /* On gcc on x86, restore the floating point mode word. */ + +#if defined(__GNUC__) && defined(__i386) + _FPU_SETCW( oldRoundingMode ); +#endif + + return retval; +} + +/* + *---------------------------------------------------------------------- + * + * MakeHighPrecisionDouble -- + * + * Makes the double precision number, signum*significand*10**exponent. + * + * Results: + * Returns the constructed number. + * + * MakeHighPrecisionDouble is used when arbitrary-precision arithmetic + * is needed to ensure correct rounding. It begins by calculating a + * low-precision approximation to the desired number, and then refines + * the answer in high precision. + * + *---------------------------------------------------------------------- + */ + +static double +MakeHighPrecisionDouble( int signum, + /* 1=negative, 0=nonnegative */ + mp_int* significand, + /* Exact significand of the number */ + int numSigDigs, + /* Number of significant digits */ + int exponent ) + /* Power of 10 by which to multiply */ +{ + + double retval; + int machexp; /* Machine exponent of a power of 10 */ + /* - * Return a number with correct sign. + * With gcc on x86, the floating point rounding mode is double-extended. + * This causes the result of double-precision calculations to be rounded + * twice: once to the precision of double-extended and then again to the + * precision of double. Double-rounding introduces gratuitous errors of + * 1 ulp, so we need to change rounding mode to 53-bits. */ - if (signum) { - v = -v; +#if defined(__GNUC__) && defined(__i386) + fpu_control_t roundTo53Bits = 0x027f; + fpu_control_t oldRoundingMode; + _FPU_GETCW( oldRoundingMode ); + _FPU_SETCW( roundTo53Bits ); +#endif + + /* Quick checks for over/underflow */ + + if ( numSigDigs + exponent - 1 > maxDigits ) { + retval = HUGE_VAL; + goto returnValue; + } + if ( numSigDigs + exponent - 1 < minDigits ) { + retval = 0; + goto returnValue; } - /* - * Restore FPU mode word and return. + /* + * Develop a first approximation to the significand. It is tempting + * simply to force bignum to double, but that will overflow on input + * numbers like 1.[string repeat 0 1000]1; while this is a not terribly + * likely scenario, we still have to deal with it. Use fraction and + * exponent instead. Once we have the significand, multiply by + * 10**exponent. Test for overflow. Convert back to a double, and + * test for underflow. */ - RestoreRoundingMode(); - return v; + retval = BignumToBiasedFrExp( significand, &machexp ); + retval = Pow10TimesFrExp( exponent, retval, &machexp ); + if ( machexp > DBL_MAX_EXP * log2FLT_RADIX ) { + retval = HUGE_VAL; + goto returnValue; + } + retval = SafeLdExp( retval, machexp ); + if ( retval < tiny ) { + retval = tiny; + } - /* - * Come here on an invalid input. + /* + * Refine the result twice. (The second refinement should be + * necessary only if the best approximation is a power of 2 + * minus 1/2 ulp). */ - error: - if (endPtr != NULL) { - *endPtr = s; + retval = RefineApproximation( retval, significand, exponent ); + retval = RefineApproximation( retval, significand, exponent ); + + /* Come here to return the computed value */ + + returnValue: + if ( signum ) { + retval = -retval; } - /* - * Restore FPU mode word and return. - */ + /* On gcc on x86, restore the floating point mode word. */ - RestoreRoundingMode(); - return 0.0; +#if defined(__GNUC__) && defined(__i386) + _FPU_SETCW( oldRoundingMode ); +#endif + return retval; } /* *---------------------------------------------------------------------- * - * RefineResult -- + * MakeNaN -- + * + * Makes a "Not a Number" given a set of bits to put in the + * tag bits * - * Given a poor approximation to a floating point number, returns a - * better one. (The better approximation is correct to within 1 ulp, and - * is entirely correct if the poor approximation is correct to 1 ulp.) + * Note that a signalling NaN is never returned. + * + *---------------------------------------------------------------------- + */ + +#ifdef IEEE_FLOATING_POINT +static double +MakeNaN( int signum, /* Sign bit (1=negative, 0=nonnegative */ + Tcl_WideUInt tags ) /* Tag bits to put in the NaN */ +{ + union { + Tcl_WideUInt iv; + double dv; + } theNaN; + + theNaN.iv = tags; + theNaN.iv &= ( ((Tcl_WideUInt) 1) << 51 ) - 1; + if ( signum ) { + theNaN.iv |= ((Tcl_WideUInt) (0x8000 | NAN_START)) << 48; + } else { + theNaN.iv |= ((Tcl_WideUInt) NAN_START) << 48; + } + + return theNaN.dv; +} +#endif + +/* + *---------------------------------------------------------------------- + * + * RefineApproximation -- + * + * Given a poor approximation to a floating point number, returns + * a better one (The better approximation is correct to within + * 1 ulp, and is entirely correct if the poor approximation is + * correct to 1 ulp.) * * Results: * Returns the improved result. @@ -534,119 +1528,109 @@ TclStrToD(CONST char *s, /* String to scan. */ */ static double -RefineResult(double approxResult, /* Approximate result of conversion. */ - CONST char* sigStart, - /* Pointer to start of significand in input - * string. */ - int nSigDigs, /* Number of significant digits. */ - long exponent) /* Power of ten to multiply by significand. */ +RefineApproximation( double approxResult, + /* Approximate result of conversion */ + mp_int* exactSignificand, + /* Integer significand */ + int exponent ) + /* Power of 10 to multiply by significand */ { - int M2, M5; /* Powers of 2 and of 5 needed to put the - * decimal and binary numbers over a common - * denominator. */ - double significand; /* Sigificand of the binary number. */ - int binExponent; /* Exponent of the binary number. */ + + int M2, M5; /* Powers of 2 and of 5 needed to put + * the decimal and binary numbers over + * a common denominator. */ + double significand; /* Sigificand of the binary number */ + int binExponent; /* Exponent of the binary number */ + int msb; /* Most significant bit position of an - * intermediate result. */ + * intermediate result */ int nDigits; /* Number of mp_digit's in an intermediate - * result. */ - mp_int twoMv; /* Approx binary value expressed as an exact - * integer scaled by the multiplier 2M. */ - mp_int twoMd; /* Exact decimal value expressed as an exact - * integer scaled by the multiplier 2M. */ - int scale; /* Scale factor for M. */ - int multiplier; /* Power of two to scale M. */ - double num, den; /* Numerator and denominator of the correction - * term. */ - double quot; /* Correction term. */ - double minincr; /* Lower bound on the absolute value of the - * correction term. */ + * result */ + mp_int twoMv; /* Approx binary value expressed as an + * exact integer scaled by the multiplier 2M */ + mp_int twoMd; /* Exact decimal value expressed as an + * exact integer scaled by the multiplier 2M */ + int scale; /* Scale factor for M */ + int multiplier; /* Power of two to scale M */ + double num, den; /* Numerator and denominator of the + * correction term */ + double quot; /* Correction term */ + double minincr; /* Lower bound on the absolute value + * of the correction term. */ int i; - const char* p; /* - * The first approximation is always low. If we find that it's HUGE_VAL, - * we're done. + * The first approximation is always low. If we find that + * it's HUGE_VAL, we're done. */ - if (approxResult == HUGE_VAL) { + if ( approxResult == HUGE_VAL ) { return approxResult; } /* - * Find a common denominator for the decimal and binary fractions. The - * common denominator will be 2**M2 + 5**M5. + * Find a common denominator for the decimal and binary fractions. + * The common denominator will be 2**M2 + 5**M5. */ - significand = frexp(approxResult, &binExponent); + significand = frexp( approxResult, &binExponent ); i = mantBits - binExponent; - if (i < 0) { + if ( i < 0 ) { M2 = 0; } else { M2 = i; } - if (exponent > 0) { + if ( exponent > 0 ) { M5 = 0; } else { M5 = -exponent; - if ((M5-1) > M2) { + if ( (M5-1) > M2 ) { M2 = M5-1; } } - /* - * The floating point number is significand*2**binExponent. The 2**-1 bit - * of the significand (the most significant) corresponds to the - * 2**(binExponent+M2 + 1) bit of 2*M2*v. Allocate enough digits to hold - * that quantity, then convert the significand to a large integer, scaled + /* + * The floating point number is significand*2**binExponent. + * Compute the large integer significand*2**(binExponent+M2+1) + * The 2**-1 bit of the significand (the most significant) + * corresponds to the 2**(binExponent+M2 + 1) bit of 2*M2*v. + * Allocate enough digits to hold that quantity, then + * convert the significand to a large integer, scaled * appropriately. Then multiply by the appropriate power of 5. */ - msb = binExponent + M2; /* 1008 */ + msb = binExponent + M2; /* 1008 */ nDigits = msb / DIGIT_BIT + 1; - mp_init_size(&twoMv, nDigits); - i = (msb % DIGIT_BIT + 1); + mp_init_size( &twoMv, nDigits ); + i = ( msb % DIGIT_BIT + 1 ); twoMv.used = nDigits; - significand *= SafeLdExp(1.0, i); - while (--nDigits >= 0) { + significand *= SafeLdExp( 1.0, i ); + while ( -- nDigits >= 0 ) { twoMv.dp[nDigits] = (mp_digit) significand; significand -= (mp_digit) significand; - significand = SafeLdExp(significand, DIGIT_BIT); + significand = SafeLdExp( significand, DIGIT_BIT ); } - for (i=0 ; i<=8 ; ++i) { - if (M5 & (1 << i)) { - mp_mul(&twoMv, pow5+i, &twoMv); + for ( i = 0; i <= 8; ++i ) { + if ( M5 & ( 1 << i ) ) { + mp_mul( &twoMv, pow5+i, &twoMv ); } } - - /* - * Collect the decimal significand as a high precision integer. The least - * significant bit corresponds to bit M2+exponent+1 so it will need to be - * shifted left by that many bits after being multiplied by - * 5**(M5+exponent). + + /* + * Collect the decimal significand as a high precision integer. + * The least significant bit corresponds to bit M2+exponent+1 + * so it will need to be shifted left by that many bits after + * being multiplied by 5**(M5+exponent). */ - mp_init(&twoMd); - mp_zero(&twoMd); - i = nSigDigs; - for (p=sigStart ;; ++p) { - char c = *p; - if (isdigit(UCHAR(c))) { - mp_mul_d(&twoMd, (unsigned) 10, &twoMd); - mp_add_d(&twoMd, (unsigned) (c - '0'), &twoMd); - --i; - if (i == 0) { - break; - } - } - } - for (i=0 ; i<=8 ; ++i) { - if ((M5+exponent) & (1 << i)) { - mp_mul(&twoMd, pow5+i, &twoMd); + mp_init_copy( &twoMd, exactSignificand ); + for ( i = 0; i <= 8; ++i ) { + if ( (M5+exponent) & ( 1 << i ) ) { + mp_mul( &twoMd, pow5+i, &twoMd ); } } - mp_mul_2d(&twoMd, M2+exponent+1, &twoMd); - mp_sub(&twoMd, &twoMv, &twoMd); + mp_mul_2d( &twoMd, M2+exponent+1, &twoMd ); + mp_sub( &twoMd, &twoMv, &twoMd ); /* * The result, 2Mv-2Md, needs to be divided by 2M to yield a correction @@ -656,135 +1640,55 @@ RefineResult(double approxResult, /* Approximate result of conversion. */ scale = binExponent - mantBits - 1; - mp_set(&twoMv, 1); - for (i=0 ; i<=8 ; ++i) { - if (M5 & (1 << i)) { - mp_mul(&twoMv, pow5+i, &twoMv); + mp_set( &twoMv, 1 ); + for ( i = 0; i <= 8; ++i ) { + if ( M5 & ( 1 << i ) ) { + mp_mul( &twoMv, pow5+i, &twoMv ); } } multiplier = M2 + scale + 1; - if (multiplier > 0) { - mp_mul_2d(&twoMv, multiplier, &twoMv); - } else if (multiplier < 0) { - mp_div_2d(&twoMv, -multiplier, &twoMv, NULL); + if ( multiplier > 0 ) { + mp_mul_2d( &twoMv, multiplier, &twoMv ); + } else if ( multiplier < 0 ) { + mp_div_2d( &twoMv, -multiplier, &twoMv, NULL ); } /* - * If the result is less than unity, the error is less than 1/2 unit in - * the last place, so there's no correction to make. + * If the result is less than unity, the error is less than 1/2 unit + * in the last place, so there's no correction to make. */ - if (mp_cmp_mag(&twoMd, &twoMv) == MP_LT) { - mp_clear(&twoMd); - mp_clear(&twoMv); + if ( mp_cmp_mag( &twoMd, &twoMv ) == MP_LT ) { return approxResult; } - /* - * Convert the numerator and denominator of the corrector term accurately - * to floating point numbers. + /* + * Convert the numerator and denominator of the corrector term + * accurately to floating point numbers. */ - num = TclBignumToDouble(&twoMd); - den = TclBignumToDouble(&twoMv); + num = TclBignumToDouble( &twoMd ); + den = TclBignumToDouble( &twoMv ); - quot = SafeLdExp(num/den, scale); - minincr = SafeLdExp(1.0, binExponent - mantBits); + quot = SafeLdExp( num/den, scale ); + minincr = SafeLdExp( 1.0, binExponent - mantBits ); - if (quot<0. && quot>-minincr) { + if ( quot < 0. && quot > -minincr ) { quot = -minincr; - } else if (quot>0. && quot<minincr) { + } else if ( quot > 0. && quot < minincr ) { quot = minincr; } - mp_clear(&twoMd); - mp_clear(&twoMv); + mp_clear( &twoMd ); + mp_clear( &twoMv ); + return approxResult + quot; } /* *---------------------------------------------------------------------- * - * ParseNaN -- - * - * Parses a "not a number" from an input string, and returns the double - * precision NaN corresponding to it. - * - * Side effects: - * Advances endPtr to follow any (hex) in the input string. - * - * If the NaN is followed by a left paren, a string of spaes and - * hexadecimal digits, and a right paren, endPtr is advanced to follow - * it. - * - * The string of hexadecimal digits is OR'ed into the resulting NaN, and - * the signum is set as well. Note that a signalling NaN is never - * returned. - * - *---------------------------------------------------------------------- - */ - -static double -ParseNaN(int signum, /* Flag == 1 if minus sign has been seen in - * front of NaN. */ - CONST char** endPtr) /* Pointer-to-pointer to char following "NaN" - * in the input string. */ -{ - const char* p = *endPtr; - char c; - union { - Tcl_WideUInt iv; - double dv; - } theNaN; - - /* - * Scan off a hex number in parentheses. Embedded blanks are ok. - */ - - theNaN.iv = 0; - if (*p == '(') { - ++p; - for (;;) { - c = *p++; - if (isspace(UCHAR(c))) { - continue; - } else if (c == ')') { - *endPtr = p; - break; - } else if (isdigit(UCHAR(c))) { - c -= '0'; - } else if (c >= 'A' && c <= 'F') { - c -= 'A' + 10; - } else if (c >= 'a' && c <= 'f') { - c -= 'a' + 10; - } else { - theNaN.iv = (((Tcl_WideUInt) NAN_START) << 48) - | (((Tcl_WideUInt) signum) << 63); - return theNaN.dv; - } - theNaN.iv = (theNaN.iv << 4) | c; - } - } - - /* - * Mask the hex number down to the least significant 51 bits. - */ - - theNaN.iv &= (((Tcl_WideUInt) 1) << 51) - 1; - if (signum) { - theNaN.iv |= ((Tcl_WideUInt) 0xfff8) << 48; - } else { - theNaN.iv |= ((Tcl_WideUInt) NAN_START) << 48; - } - - *endPtr = p; - return theNaN.dv; -} - -/* - *---------------------------------------------------------------------- - * * TclDoubleDigits -- * * Converts a double to a string of digits. @@ -803,20 +1707,21 @@ ParseNaN(int signum, /* Flag == 1 if minus sign has been seen in */ int -TclDoubleDigits(char * strPtr, /* Buffer in which to store the result, must - * have at least 18 chars. */ - double v, /* Number to convert. Must be finite, and not - * NaN. */ - int *signum) /* Output: 1 if the number is negative. - * Should handle -0 correctly on the IEEE - * architecture. */ +TclDoubleDigits( char * string, /* Buffer in which to store the result, + * must have at least 18 chars */ + double v, /* Number to convert. Must be + * finite, and not NaN */ + int *signum ) /* Output: 1 if the number is negative. + * Should handle -0 correctly on the + * IEEE architecture. */ { - double f; /* Significand of v. */ int e; /* Power of FLT_RADIX that satisfies * v = f * FLT_RADIX**e */ int lowOK, highOK; mp_int r; /* Scaled significand. */ mp_int s; /* Divisor such that v = r / s */ + int smallestSig; /* Flag == 1 iff v's significand is + * the smallest that can be represented. */ mp_int mplus; /* Scaled epsilon: (r + 2* mplus) == v(+) * where v(+) is the floating point successor * of v. */ @@ -830,103 +1735,31 @@ TclDoubleDigits(char * strPtr, /* Buffer in which to store the result, must int sfac5 = 0; int mplusfac2 = 0; int mminusfac2 = 0; - double a; char c; int i, k, n; - /* - * Take the absolute value of the number, and report the number's sign. - * Take special steps to preserve signed zeroes in IEEE floating point. - * (We can't use fpclassify, because that's a C9x feature and we still - * have to build on C89 compilers.) - */ + /* Split the number into absolute value and signum. */ -#ifndef IEEE_FLOATING_POINT - if (v >= 0.0) { - *signum = 0; - } else { - *signum = 1; - v = -v; - } -#else - union { - Tcl_WideUInt iv; - double dv; - } bitwhack; - bitwhack.dv = v; - if (bitwhack.iv & ((Tcl_WideUInt) 1 << 63)) { - *signum = 1; - bitwhack.iv &= ~((Tcl_WideUInt) 1 << 63); - v = bitwhack.dv; - } else { - *signum = 0; - } -#endif + v = AbsoluteValue(v, signum); /* * Handle zero specially. */ - if (v == 0.0) { - *strPtr++ = '0'; - *strPtr++ = '\0'; + if ( v == 0.0 ) { + *string++ = '0'; + *string++ = '\0'; return 1; } - /* - * Develop f and e such that v = f * FLT_RADIX**e, with - * 1.0/FLT_RADIX <= f < 1. + /* + * Find a large integer r, and integer e, such that + * v = r * FLT_RADIX**e + * and r is as small as possible. Also determine whether the + * significand is the smallest possible. */ - f = frexp(v, &e); - n = e % log2FLT_RADIX; - if (n > 0) { - n -= log2FLT_RADIX; - e += 1; - } - f *= ldexp(1.0, n); - e = (e - n) / log2FLT_RADIX; - if (f == 1.0) { - f = 1.0 / FLT_RADIX; - e += 1; - } - - /* - * If the original number was denormalized, adjust e and f to be denormal - * as well. - */ - - if (e < DBL_MIN_EXP) { - n = mantBits + (e - DBL_MIN_EXP)*log2FLT_RADIX; - f = ldexp(f, (e - DBL_MIN_EXP)*log2FLT_RADIX); - e = DBL_MIN_EXP; - n = (n + DIGIT_BIT - 1) / DIGIT_BIT; - } else { - n = mantDIGIT; - } - - /* - * Now extract the base-2**DIGIT_BIT digits of f into a multi-precision - * integer r. Preserve the invariant v = r * 2**rfac2 * FLT_RADIX**e by - * adjusting e. - */ - - a = f; - n = mantDIGIT; - mp_init_size(&r, n); - r.used = n; - r.sign = MP_ZPOS; - i = (mantBits % DIGIT_BIT); - if (i == 0) { - i = DIGIT_BIT; - } - while (n > 0) { - a *= ldexp(1.0, i); - i = DIGIT_BIT; - r.dp[--n] = (mp_digit) a; - a -= (mp_digit) a; - } - e -= DBL_MANT_DIG; + smallestSig = GetIntegerTimesPower(v, &r, &e); lowOK = highOK = (mp_iseven(&r)); @@ -943,12 +1776,12 @@ TclDoubleDigits(char * strPtr, /* Buffer in which to store the result, must if (e >= 0) { int bits = e * log2FLT_RADIX; - if (f != 1.0/FLT_RADIX) { + if (!smallestSig) { /* * Normal case, m+ and m- are both FLT_RADIX**e */ - rfac2 += bits + 1; + rfac2 = bits + 1; sfac2 = 1; mplusfac2 = bits; mminusfac2 = bits; @@ -959,7 +1792,7 @@ TclDoubleDigits(char * strPtr, /* Buffer in which to store the result, must * smaller exponent when going to e's predecessor. */ - rfac2 += bits + log2FLT_RADIX + 1; + rfac2 = bits + log2FLT_RADIX + 1; sfac2 = 1 + log2FLT_RADIX; mplusfac2 = bits + log2FLT_RADIX; mminusfac2 = bits; @@ -969,13 +1802,13 @@ TclDoubleDigits(char * strPtr, /* Buffer in which to store the result, must * v has digits after the binary point */ - if (e <= DBL_MIN_EXP-DBL_MANT_DIG || f != 1.0/FLT_RADIX) { + if (e <= DBL_MIN_EXP-DBL_MANT_DIG || !smallestSig) { /* * Either f isn't the smallest significand or e is the smallest * exponent. mplus and mminus will both be 1. */ - rfac2 += 1; + rfac2 = 1; sfac2 = 1 - e * log2FLT_RADIX; mplusfac2 = 0; mminusfac2 = 0; @@ -986,7 +1819,7 @@ TclDoubleDigits(char * strPtr, /* Buffer in which to store the result, must * fact that v's predecessor has a smaller exponent. */ - rfac2 += 1 + log2FLT_RADIX; + rfac2 = 1 + log2FLT_RADIX; sfac2 = 1 + log2FLT_RADIX * (1 - e); mplusfac2 = FLT_RADIX; mminusfac2 = 0; @@ -1081,9 +1914,9 @@ TclDoubleDigits(char * strPtr, /* Buffer in which to store the result, must } else { tc2= (tc2 > 0); } - if (!tc1) { - if (!tc2) { - *strPtr++ = '0' + i; + if ( ! tc1 ) { + if ( !tc2 ) { + *string++ = '0' + i; } else { c = (char) (i + '1'); break; @@ -1103,8 +1936,8 @@ TclDoubleDigits(char * strPtr, /* Buffer in which to store the result, must break; } }; - *strPtr++ = c; - *strPtr++ = '\0'; + *string++ = c; + *string++ = '\0'; /* * Free memory, and return. @@ -1117,6 +1950,148 @@ TclDoubleDigits(char * strPtr, /* Buffer in which to store the result, must /* *---------------------------------------------------------------------- * + * AbsoluteValue -- + * + * Splits a 'double' into its absolute value and sign. + * + * Results: + * Returns the absolute value. + * + * Side effects: + * Stores the signum in '*signum'. + * + *---------------------------------------------------------------------- + */ + +static double +AbsoluteValue (double v, /* Number to split */ + int* signum) /* (Output) Sign of the number 1=-, 0=+ */ +{ + /* + * Take the absolute value of the number, and report the number's sign. + * Take special steps to preserve signed zeroes in IEEE floating point. + * (We can't use fpclassify, because that's a C9x feature and we still + * have to build on C89 compilers.) + */ + +#ifndef IEEE_FLOATING_POINT + if (v >= 0.0) { + *signum = 0; + } else { + *signum = 1; + v = -v; + } +#else + union { + Tcl_WideUInt iv; + double dv; + } bitwhack; + bitwhack.dv = v; + if (bitwhack.iv & ((Tcl_WideUInt) 1 << 63)) { + *signum = 1; + bitwhack.iv &= ~((Tcl_WideUInt) 1 << 63); + v = bitwhack.dv; + } else { + *signum = 0; + } +#endif + return v; +} + +/* + *---------------------------------------------------------------------- + * + * GetIntegerTimesPower -- + * + * Converts a floating point number to an exact integer times a + * power of the floating point radix. + * + * Results: + * Returns 1 if it converted the smallest significand, 0 otherwise. + * + * Side effects: + * Initializes the integer value (does not just assign it), + * and stores the exponent. + * + *---------------------------------------------------------------------- + */ + +static int +GetIntegerTimesPower(double v, /* Value to convert */ + mp_int* rPtr, + /* (Output) Integer value */ + int* ePtr) /* (Output) Power of FLT_RADIX by which + * r must be multiplied to yield v*/ +{ + + double a; + double f; + int e; + int i; + int n; + + /* + * Develop f and e such that v = f * FLT_RADIX**e, with + * 1.0/FLT_RADIX <= f < 1. + */ + + f = frexp(v, &e); +#if FLT_RADIX > 2 + n = e % log2FLT_RADIX; + if (n > 0) { + n -= log2FLT_RADIX; + e += 1; + f *= ldexp(1.0, n); + } + e = (e - n) / log2FLT_RADIX; +#endif + if (f == 1.0) { + f = 1.0 / FLT_RADIX; + e += 1; + } + + /* + * If the original number was denormalized, adjust e and f to be denormal + * as well. + */ + + if (e < DBL_MIN_EXP) { + n = mantBits + (e - DBL_MIN_EXP)*log2FLT_RADIX; + f = ldexp(f, (e - DBL_MIN_EXP)*log2FLT_RADIX); + e = DBL_MIN_EXP; + n = (n + DIGIT_BIT - 1) / DIGIT_BIT; + } else { + n = mantDIGIT; + } + + /* + * Now extract the base-2**DIGIT_BIT digits of f into a multi-precision + * integer r. Preserve the invariant v = r * 2**rfac2 * FLT_RADIX**e by + * adjusting e. + */ + + a = f; + n = mantDIGIT; + mp_init_size(rPtr, n); + rPtr->used = n; + rPtr->sign = MP_ZPOS; + i = (mantBits % DIGIT_BIT); + if (i == 0) { + i = DIGIT_BIT; + } + while (n > 0) { + a *= ldexp(1.0, i); + i = DIGIT_BIT; + rPtr->dp[--n] = (mp_digit) a; + a -= (mp_digit) a; + } + *ePtr = e - DBL_MANT_DIG; + return (f == 1.0 / FLT_RADIX); +} + +/* + *---------------------------------------------------------------------- + * * TclInitDoubleConversion -- * * Initializes constants that are needed for conversions to and from @@ -1138,16 +2113,43 @@ TclInitDoubleConversion(void) { int i; int x; + Tcl_WideUInt u; double d; - if (frexp((double) FLT_RADIX, &log2FLT_RADIX) != 0.5) { - Tcl_Panic("This code doesn't work on a decimal machine!"); + /* + * Initialize table of powers of 10 expressed as wide integers. + */ + + maxpow10_wide = + (int) floor(sizeof (Tcl_WideUInt) * CHAR_BIT * log (2.) / log (10.)); + pow10_wide = (Tcl_WideUInt*) Tcl_Alloc ((maxpow10_wide + 1) + * sizeof (Tcl_WideUInt)); + u = 1; + for (i = 0; i < maxpow10_wide; ++i) { + pow10_wide[i] = u; + u *= 10; + } + pow10_wide[i] = u; + + /* + * Determine how many bits of precision a double has, and how many + * decimal digits that represents. + */ + + if ( frexp( (double) FLT_RADIX, &log2FLT_RADIX ) != 0.5 ) { + Tcl_Panic( "This code doesn't work on a decimal machine!" ); } --log2FLT_RADIX; mantBits = DBL_MANT_DIG * log2FLT_RADIX; d = 1.0; - x = (int) (DBL_MANT_DIG * log((double) FLT_RADIX) / log(5.0)); - if (x < MAXPOW) { + + /* + * Initialize a table of powers of ten that can be exactly represented + * in a double. + */ + + x = (int) (DBL_MANT_DIG * log((double) FLT_RADIX) / log( 5.0 )); + if ( x < MAXPOW ) { mmaxpow = x; } else { mmaxpow = MAXPOW; @@ -1156,19 +2158,32 @@ TclInitDoubleConversion(void) pow10[i] = d; d *= 10.0; } - for (i=0 ; i<9 ; ++i) { - mp_init(pow5 + i); + + /* Initialize a table of large powers of five. */ + + for ( i = 0; i < 9; ++i ) { + mp_init( pow5 + i ); } - mp_set(pow5, 5); - for (i=0 ; i<8 ; ++i) { - mp_sqr(pow5+i, pow5+i+1); + mp_set( pow5, 5 ); + for ( i = 0; i < 8; ++i ) { + mp_sqr( pow5+i, pow5+i+1 ); } - tiny = SafeLdExp(1.0, DBL_MIN_EXP * log2FLT_RADIX - mantBits); - maxDigits = (int) - ((DBL_MAX_EXP * log((double) FLT_RADIX) + log(10.)/2) / log(10.)); - minDigits = (int) - floor((DBL_MIN_EXP-DBL_MANT_DIG)*log((double)FLT_RADIX)/log(10.)); - mantDIGIT = (mantBits + DIGIT_BIT - 1) / DIGIT_BIT; + + /* + * Determine the number of decimal digits to the left and right of the + * decimal point in the largest and smallest double, the smallest double + * that differs from zero, and the number of mp_digits needed to represent + * the significand of a double. + */ + + tiny = SafeLdExp( 1.0, DBL_MIN_EXP * log2FLT_RADIX - mantBits ); + maxDigits = (int) ((DBL_MAX_EXP * log((double) FLT_RADIX) + + 0.5 * log(10.)) + / log( 10. )); + minDigits = (int) floor ( ( DBL_MIN_EXP - DBL_MANT_DIG ) + * log( (double) FLT_RADIX ) / log( 10. ) ); + mantDIGIT = ( mantBits + DIGIT_BIT - 1 ) / DIGIT_BIT; + log10_DIGIT_MAX = (int) floor (DIGIT_BIT * log(2.) / log (10.)); } /* @@ -1191,9 +2206,62 @@ void TclFinalizeDoubleConversion() { int i; - for (i=0 ; i<9 ; ++i) { - mp_clear(pow5 + i); + Tcl_Free ((char*)pow10_wide); + for ( i = 0; i < 9; ++i ) { + mp_clear( pow5 + i ); + } +} + +/* + *---------------------------------------------------------------------- + * + * TclInitBignumFromDouble -- + * + * Extracts the integer part of a double and converts it to + * an arbitrary precision integer. + * + * Results: + * None. + * + * Side effects: + * Initializes the bignum supplied, and stores the converted number + * in it. + * + *---------------------------------------------------------------------- + */ + +int +TclInitBignumFromDouble(Tcl_Interp *interp, /* For error message */ + double d, /* Number to convert */ + mp_int* b) /* Place to store the result */ +{ + double fract; + int expt; + + /* Infinite values can't convert to bignum */ + if (TclIsInfinite(d)) { + if (interp != NULL) { + char *s = "integer value too large to represent"; + Tcl_SetObjResult(interp, Tcl_NewStringObj(s, -1)); + Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", s, NULL); + } + return TCL_ERROR; + } + fract = frexp(d,&expt); + if (expt <= 0) { + mp_init(b); + mp_zero(b); + } else { + Tcl_WideInt w = (Tcl_WideInt) ldexp(fract, mantBits); + int shift = expt - mantBits; + TclBNInitBignumFromWideInt(b, w); + if (shift < 0) { + mp_div_2d(b, -shift, b, NULL); + } else if (shift > 0) { + mp_mul_2d(b, shift, b); + } } + return TCL_OK; } /* @@ -1228,7 +2296,11 @@ TclBignumToDouble(mp_int *a) /* Integer to convert. */ bits = mp_count_bits(a); if (bits > DBL_MAX_EXP*log2FLT_RADIX) { errno = ERANGE; - return HUGE_VAL; + if (a->sign == MP_ZPOS) { + return HUGE_VAL; + } else { + return -HUGE_VAL; + } } shift = mantBits + 1 - bits; mp_init(&b); @@ -1268,6 +2340,210 @@ TclBignumToDouble(mp_int *a) /* Integer to convert. */ return -r; } } + +double +TclCeil(mp_int *a) /* Integer to convert. */ +{ + double r = 0.0; + mp_int b; + + mp_init(&b); + if (mp_cmp_d(a, 0) == MP_LT) { + mp_neg(a, &b); + r = -TclFloor(&b); + } else { + int bits = mp_count_bits(a); + + if (bits > DBL_MAX_EXP*log2FLT_RADIX) { + r = HUGE_VAL; + } else { + int i, exact = 1, shift = mantBits - bits; + + if (shift > 0) { + mp_mul_2d(a, shift, &b); + } else if (shift < 0) { + mp_int d; + mp_init(&d); + mp_div_2d(a, -shift, &b, &d); + exact = mp_iszero(&d); + mp_clear(&d); + } else { + mp_copy(a, &b); + } + if (!exact) { + mp_add_d(&b, 1, &b); + } + for (i=b.used-1 ; i>=0 ; --i) { + r = ldexp(r, DIGIT_BIT) + b.dp[i]; + } + r = ldexp(r, bits - mantBits); + } + } + mp_clear(&b); + return r; +} + +double +TclFloor(mp_int *a) /* Integer to convert. */ +{ + double r = 0.0; + mp_int b; + + mp_init(&b); + if (mp_cmp_d(a, 0) == MP_LT) { + mp_neg(a, &b); + r = -TclCeil(&b); + } else { + int bits = mp_count_bits(a); + + if (bits > DBL_MAX_EXP*log2FLT_RADIX) { + r = DBL_MAX; + } else { + int i, shift = mantBits - bits; + + if (shift > 0) { + mp_mul_2d(a, shift, &b); + } else if (shift < 0) { + mp_div_2d(a, -shift, &b, NULL); + } else { + mp_copy(a, &b); + } + for (i=b.used-1 ; i>=0 ; --i) { + r = ldexp(r, DIGIT_BIT) + b.dp[i]; + } + r = ldexp(r, bits - mantBits); + } + } + mp_clear(&b); + return r; +} + +/* + *---------------------------------------------------------------------- + * + * BignumToBiasedFrExp -- + * + * Convert an arbitrary-precision integer to a native floating + * point number in the range [0.5,1) times a power of two. + * NOTE: Intentionally converts to a number that's a few + * ulp too small, so that RefineApproximation will not overflow + * near the high end of the machine's arithmetic range. + * + * Results: + * Returns the converted number. + * + * Side effects: + * Stores the exponent of two in 'machexp'. + * + *---------------------------------------------------------------------- + */ + +static double +BignumToBiasedFrExp( mp_int* a, + /* Integer to convert */ + int* machexp ) + /* Power of two */ +{ + mp_int b; + int bits; + int shift; + int i; + double r; + + /* Determine how many bits we need, and extract that many from + * the input. Round to nearest unit in the last place. */ + + bits = mp_count_bits( a ); + shift = mantBits - 2 - bits; + mp_init( &b ); + if ( shift > 0 ) { + mp_mul_2d( a, shift, &b ); + } else if ( shift < 0 ) { + mp_div_2d( a, -shift, &b, NULL ); + } else { + mp_copy( a, &b ); + } + + /* Accumulate the result, one mp_digit at a time */ + + r = 0.0; + for ( i = b.used-1; i >= 0; --i ) { + r = ldexp( r, DIGIT_BIT ) + b.dp[i]; + } + mp_clear( &b ); + + /* Return the result with the appropriate sign. */ + + *machexp = bits - mantBits + 2; + if ( a->sign == MP_ZPOS ) { + return r; + } else { + return -r; + } +} + +/* + *---------------------------------------------------------------------- + * + * Pow10TimesFrExp -- + * + * Multiply a power of ten by a number expressed as fraction and + * exponent. + * + * Results: + * Returns the significand of the result. + * + * Side effects: + * Overwrites the 'machexp' parameter with the exponent of the + * result. + * + * Assumes that 'exponent' is such that 10**exponent would be a double, + * even though 'fraction*10**(machexp+exponent)' might overflow. + * + *---------------------------------------------------------------------- + */ + +static double +Pow10TimesFrExp( int exponent, /* Power of 10 to multiply by */ + double fraction, + /* Significand of multiplicand */ + int* machexp ) /* On input, exponent of multiplicand. + * On output, exponent of result. */ +{ + int i, j; + int expt = *machexp; + double retval = fraction; + + if ( exponent > 0 ) { + + /* Multiply by 10**exponent */ + + retval = frexp( retval * pow10[ exponent & 0xf ], &j ); + expt += j; + for ( i = 4; i < 9; ++i ) { + if ( exponent & (1<<i) ) { + retval = frexp( retval * pow_10_2_n[ i ], &j ); + expt += j; + } + } + } else if ( exponent < 0 ) { + + /* Divide by 10**-exponent */ + + retval = frexp( retval / pow10[ (-exponent) & 0xf ], &j ); + expt += j; + for ( i = 4; i < 9; ++i ) { + if ( (-exponent) & (1<<i) ) { + retval = frexp( retval / pow_10_2_n[ i ], &j ); + expt += j; + } + } + } + + *machexp = expt; + return retval; + +} /* *---------------------------------------------------------------------- diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index d5dedc2..74b6f83 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -33,9 +33,10 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclStringObj.c,v 1.48 2005/09/15 16:58:24 dgp Exp $ */ + * RCS: @(#) $Id: tclStringObj.c,v 1.49 2005/10/08 14:42:45 dgp Exp $ */ #include "tclInt.h" +#include "tommath.h" /* * Prototypes for functions defined later in this file: @@ -386,6 +387,8 @@ Tcl_GetCharLength(objPtr) * string to count continuous ascii characters before resorting to the * Tcl_NumUtfChars call. This is a long form of: stringPtr->numChars = Tcl_NumUtfChars(objPtr->bytes,objPtr->length); + * + * TODO: Consider macro-izing this. */ while (i && (*str < 0xC0)) { @@ -1722,7 +1725,7 @@ TclAppendFormattedObjs(interp, appendObj, format, objc, objv) while (*format != '\0') { char *end; int gotMinus, gotHash, gotZero, gotSpace, gotPlus, sawFlag; - int width, gotPrecision, precision, useShort, useWide; + int width, gotPrecision, precision, useShort, useWide, useBig; int newXpg, numChars, allocSegment = 0; Tcl_Obj *segment; Tcl_UniChar ch; @@ -1865,17 +1868,23 @@ TclAppendFormattedObjs(interp, appendObj, format, objc, objv) /* 5. Length modifier */ - useShort = useWide = 0; + useShort = useWide = useBig = 0; if (ch == 'h') { useShort = 1; format += step; step = Tcl_UtfToUniChar(format, &ch); } else if (ch == 'l') { + format += step; + step = Tcl_UtfToUniChar(format, &ch); + if (ch == 'l') { + useBig = 1; + format += step; + step = Tcl_UtfToUniChar(format, &ch); + } else { #ifndef TCL_WIDE_INT_IS_LONG useWide = 1; #endif - format += step; - step = Tcl_UtfToUniChar(format, &ch); + } } format += step; @@ -1913,6 +1922,10 @@ TclAppendFormattedObjs(interp, appendObj, format, objc, objv) } case 'u': + if (useBig) { + msg = "unsigned bignum format is invalid"; + goto errorMsg; + } case 'd': case 'o': case 'x': @@ -1920,26 +1933,54 @@ TclAppendFormattedObjs(interp, appendObj, format, objc, objv) short int s; long l; Tcl_WideInt w; + mp_int big; int isNegative = 0; - if (useWide) { - if (Tcl_GetWideIntFromObj(interp, segment, &w) != TCL_OK) { - goto error; - } - } else if (Tcl_GetLongFromObj(NULL, segment, &l) != TCL_OK) { - if (Tcl_GetWideIntFromObj(interp, segment, &w) != TCL_OK) { + if (useBig) { + if (Tcl_GetBignumFromObj(interp, segment, &big) != TCL_OK) { goto error; } - l = Tcl_WideAsLong(w); - } - - if (useShort) { - s = (short int) l; - isNegative = (s < (short int)0); + isNegative = (mp_cmp_d(&big, 0) == MP_LT); } else if (useWide) { + if (Tcl_GetWideIntFromObj(NULL, segment, &w) != TCL_OK) { + Tcl_Obj *objPtr; + if (Tcl_GetBignumFromObj(interp, segment, &big) != TCL_OK) { + goto error; + } + mp_mod_2d(&big, (int) CHAR_BIT * sizeof(Tcl_WideInt), &big); + objPtr = Tcl_NewBignumObj(&big); + Tcl_IncrRefCount(objPtr); + Tcl_GetWideIntFromObj(NULL, objPtr, &w); + Tcl_DecrRefCount(objPtr); + } isNegative = (w < (Tcl_WideInt)0); + } else if (Tcl_GetLongFromObj(NULL, segment, &l) != TCL_OK) { + if (Tcl_GetWideIntFromObj(NULL, segment, &w) != TCL_OK) { + Tcl_Obj *objPtr; + if (Tcl_GetBignumFromObj(interp, segment, &big) != TCL_OK) { + goto error; + } + mp_mod_2d(&big, (int) CHAR_BIT * sizeof(long), &big); + objPtr = Tcl_NewBignumObj(&big); + Tcl_IncrRefCount(objPtr); + Tcl_GetLongFromObj(NULL, objPtr, &l); + Tcl_DecrRefCount(objPtr); + } else { + l = Tcl_WideAsLong(w); + } + if (useShort) { + s = (short int) l; + isNegative = (s < (short int)0); + } else { + isNegative = (l < (long)0); + } } else { - isNegative = (l < (long)0); + if (useShort) { + s = (short int) l; + isNegative = (s < (short int)0); + } else { + isNegative = (l < (long)0); + } } segment = Tcl_NewObj(); @@ -1947,7 +1988,7 @@ TclAppendFormattedObjs(interp, appendObj, format, objc, objv) Tcl_IncrRefCount(segment); if (isNegative || gotPlus) { - if (ch == 'd') { + if (useBig || (ch == 'd')) { if (isNegative) { Tcl_AppendToObj(segment, "-", 1); } else { @@ -1975,26 +2016,18 @@ TclAppendFormattedObjs(interp, appendObj, format, objc, objv) Tcl_Obj *pure; CONST char *bytes; - if (isNegative) { - if (useShort) { - pure = Tcl_NewIntObj((int)(-s)); - } else if (useWide) { - pure = Tcl_NewWideIntObj(-w); - } else { - pure = Tcl_NewLongObj(-l); - } + if (useShort) { + pure = Tcl_NewIntObj((int)(s)); + } else if (useWide) { + pure = Tcl_NewWideIntObj(w); + } else if (useBig) { + pure = Tcl_NewBignumObj(&big); } else { - if (useShort) { - pure = Tcl_NewIntObj((int)(s)); - } else if (useWide) { - pure = Tcl_NewWideIntObj(w); - } else { - pure = Tcl_NewLongObj(l); - } + pure = Tcl_NewLongObj(l); } Tcl_IncrRefCount(pure); bytes = Tcl_GetStringFromObj(pure, &length); - /* Handle things like -INT_MIN == INT_MIN */ + /* Already did the sign above */ if (*bytes == '-') { length--; bytes++; } @@ -2024,8 +2057,9 @@ TclAppendFormattedObjs(interp, appendObj, format, objc, objv) case 'o': case 'x': case 'X': { - Tcl_WideUInt bits; - int length, numDigits = 0, base = 16; + Tcl_WideUInt bits = (Tcl_WideUInt)0; + int length, numBits = 4, numDigits = 0, base = 16; + int index = 0, shift = 0; Tcl_Obj *pure; char *bytes; @@ -2034,6 +2068,7 @@ TclAppendFormattedObjs(interp, appendObj, format, objc, objv) } if (ch == 'o') { base = 8; + numBits = 3; } if (useShort) { unsigned short int us = (unsigned short int) s; @@ -2049,6 +2084,14 @@ TclAppendFormattedObjs(interp, appendObj, format, objc, objv) numDigits++; uw /= base; } + } else if (useBig) { + int leftover = (big.used * DIGIT_BIT) % numBits; + mp_digit mask = (~(mp_digit)0) << (DIGIT_BIT-leftover); + numDigits = 1 + ((big.used * DIGIT_BIT) / numBits); + while ((mask & big.dp[big.used-1]) == 0) { + numDigits--; + mask >>= numBits; + } } else { unsigned long int ul = (unsigned long int) l; bits = (Tcl_WideUInt) ul; @@ -2066,7 +2109,15 @@ TclAppendFormattedObjs(interp, appendObj, format, objc, objv) bytes = Tcl_GetString(pure); length = numDigits; while (numDigits--) { - int digitOffset = (int) (bits % base); + int digitOffset; + if (useBig) { + if (shift<CHAR_BIT*sizeof(Tcl_WideUInt)-DIGIT_BIT) { + bits |= (((Tcl_WideUInt)big.dp[index++]) << shift); + shift += DIGIT_BIT; + } + shift -= numBits; + } + digitOffset = (int) (bits % base); if (digitOffset > 9) { bytes[numDigits] = 'a' + digitOffset - 10; } else { diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index b27ab3d..2b87660 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -8,7 +8,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclStubInit.c,v 1.122 2005/08/24 17:56:23 andreas_kupries Exp $ + * RCS: @(#) $Id: tclStubInit.c,v 1.123 2005/10/08 14:42:45 dgp Exp $ */ #include "tclInt.h" @@ -128,7 +128,7 @@ TclIntStubs tclIntStubs = { TclInExit, /* 46 */ NULL, /* 47 */ NULL, /* 48 */ - TclIncrVar2, /* 49 */ + NULL, /* 49 */ TclInitCompiledLocals, /* 50 */ TclInterpInit, /* 51 */ NULL, /* 52 */ @@ -224,7 +224,7 @@ TclIntStubs tclIntStubs = { NULL, /* 137 */ TclGetEnv, /* 138 */ NULL, /* 139 */ - TclLooksLikeInt, /* 140 */ + NULL, /* 140 */ TclpGetCwd, /* 141 */ TclSetByteCodeFromAny, /* 142 */ TclAddLiteralObj, /* 143 */ @@ -258,7 +258,7 @@ TclIntStubs tclIntStubs = { TclCheckExecutionTraces, /* 171 */ TclInThreadExit, /* 172 */ TclUniCharMatch, /* 173 */ - TclIncrWideVar2, /* 174 */ + NULL, /* 174 */ TclCallVarTraces, /* 175 */ TclCleanupVar, /* 176 */ TclVarErrMsg, /* 177 */ @@ -982,12 +982,13 @@ TclStubs tclStubs = { Tcl_DbNewBignumObj, /* 556 */ Tcl_SetBignumObj, /* 557 */ Tcl_GetBignumFromObj, /* 558 */ - Tcl_TruncateChannel, /* 559 */ - Tcl_ChannelTruncateProc, /* 560 */ - Tcl_SetChannelErrorInterp, /* 561 */ - Tcl_GetChannelErrorInterp, /* 562 */ - Tcl_SetChannelError, /* 563 */ - Tcl_GetChannelError, /* 564 */ + Tcl_GetBignumAndClearObj, /* 559 */ + Tcl_TruncateChannel, /* 560 */ + Tcl_ChannelTruncateProc, /* 561 */ + Tcl_SetChannelErrorInterp, /* 562 */ + Tcl_GetChannelErrorInterp, /* 563 */ + Tcl_SetChannelError, /* 564 */ + Tcl_GetChannelError, /* 565 */ }; /* !END!: Do not edit above this line. */ diff --git a/generic/tclTest.c b/generic/tclTest.c index 8c0067f..8e09f5e 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -14,7 +14,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclTest.c,v 1.96 2005/09/08 14:10:55 dkf Exp $ + * RCS: @(#) $Id: tclTest.c,v 1.97 2005/10/08 14:42:45 dgp Exp $ */ #define TCL_TEST @@ -258,6 +258,14 @@ static int TestexithandlerCmd _ANSI_ARGS_((ClientData dummy, Tcl_Interp *interp, int argc, CONST char **argv)); static int TestexprlongCmd _ANSI_ARGS_((ClientData dummy, Tcl_Interp *interp, int argc, CONST char **argv)); +static int TestexprlongobjCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[])); +static int TestexprdoubleCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int argc, CONST char **argv)); +static int TestexprdoubleobjCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[])); static int TestexprparserObjCmd _ANSI_ARGS_((ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); @@ -640,6 +648,12 @@ Tcltest_Init(interp) (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); Tcl_CreateCommand(interp, "testexprlong", TestexprlongCmd, (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateObjCommand(interp, "testexprlongobj", TestexprlongobjCmd, + (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateCommand(interp, "testexprdouble", TestexprdoubleCmd, + (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateObjCommand(interp, "testexprdoubleobj", TestexprdoubleobjCmd, + (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); Tcl_CreateObjCommand(interp, "testexprparser", TestexprparserObjCmd, (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); Tcl_CreateCommand(interp, "testexprstring", TestexprstringCmd, @@ -2315,6 +2329,135 @@ TestexprlongCmd(clientData, interp, argc, argv) /* *---------------------------------------------------------------------- * + * TestexprlongobjCmd -- + * + * This procedure verifies that Tcl_ExprLongObj does not modify the + * interpreter result if there is no error. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +TestexprlongobjCmd(clientData, interp, objc, objv) + ClientData clientData; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST *objv; /* Argument objects. */ +{ + long exprResult; + char buf[4 + TCL_INTEGER_SPACE]; + int result; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "expression"); + return TCL_ERROR; + } + Tcl_SetResult(interp, "This is a result", TCL_STATIC); + result = Tcl_ExprLongObj(interp, objv[1], &exprResult); + if (result != TCL_OK) { + return result; + } + sprintf(buf, ": %ld", exprResult); + Tcl_AppendResult(interp, buf, NULL); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TestexprdoubleCmd -- + * + * This procedure verifies that Tcl_ExprDouble does not modify the + * interpreter result if there is no error. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +TestexprdoubleCmd(clientData, interp, argc, argv) + ClientData clientData; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + CONST char **argv; /* Argument strings. */ +{ + double exprResult; + char buf[4 + TCL_DOUBLE_SPACE]; + int result; + + if (argc != 2) { + Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0], + " expression\"", (char *) NULL); + return TCL_ERROR; + } + Tcl_SetResult(interp, "This is a result", TCL_STATIC); + result = Tcl_ExprDouble(interp, argv[1], &exprResult); + if (result != TCL_OK) { + return result; + } + strcpy(buf, ": "); + Tcl_PrintDouble(interp, exprResult, buf+2); + Tcl_AppendResult(interp, buf, NULL); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TestexprdoubleobjCmd -- + * + * This procedure verifies that Tcl_ExprLongObj does not modify the + * interpreter result if there is no error. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +TestexprdoubleobjCmd(clientData, interp, objc, objv) + ClientData clientData; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST *objv; /* Argument objects. */ +{ + double exprResult; + char buf[4 + TCL_DOUBLE_SPACE]; + int result; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "expression"); + return TCL_ERROR; + } + Tcl_SetResult(interp, "This is a result", TCL_STATIC); + result = Tcl_ExprDoubleObj(interp, objv[1], &exprResult); + if (result != TCL_OK) { + return result; + } + strcpy(buf, ": "); + Tcl_PrintDouble(interp, exprResult, buf+2); + Tcl_AppendResult(interp, buf, NULL); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * * TestexprstringCmd -- * * This procedure tests the basic operation of Tcl_ExprString. diff --git a/generic/tclTestObj.c b/generic/tclTestObj.c index 1a07b87..51e91cf 100644 --- a/generic/tclTestObj.c +++ b/generic/tclTestObj.c @@ -13,7 +13,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclTestObj.c,v 1.14 2005/06/07 09:18:14 dkf Exp $ + * RCS: @(#) $Id: tclTestObj.c,v 1.15 2005/10/08 14:42:45 dgp Exp $ */ #include "tclInt.h" @@ -45,9 +45,11 @@ static int TestbignumobjCmd _ANSI_ARGS_((ClientData dummy, static int TestbooleanobjCmd _ANSI_ARGS_((ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); +#if 0 static int TestconvertobjCmd _ANSI_ARGS_((ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); +#endif static int TestdoubleobjCmd _ANSI_ARGS_((ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); @@ -104,8 +106,10 @@ TclObjTest_Init(interp) (ClientData) 0, (Tcl_CmdDeleteProc*) NULL ); Tcl_CreateObjCommand(interp, "testbooleanobj", TestbooleanobjCmd, (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); +#if 0 Tcl_CreateObjCommand(interp, "testconvertobj", TestconvertobjCmd, (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); +#endif Tcl_CreateObjCommand(interp, "testdoubleobj", TestdoubleobjCmd, (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); Tcl_CreateObjCommand(interp, "testintobj", TestintobjCmd, @@ -370,6 +374,7 @@ TestbooleanobjCmd(clientData, interp, objc, objv) return TCL_OK; } +#if 0 /* *---------------------------------------------------------------------- * @@ -423,6 +428,7 @@ TestconvertobjCmd(clientData, interp, objc, objv) } return TCL_OK; } +#endif /* *---------------------------------------------------------------------- diff --git a/generic/tclThreadTest.c b/generic/tclThreadTest.c index cca3c5f..50dd8c9 100644 --- a/generic/tclThreadTest.c +++ b/generic/tclThreadTest.c @@ -11,11 +11,13 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclThreadTest.c,v 1.21 2005/08/26 22:11:16 andreas_kupries Exp $ + * RCS: @(#) $Id: tclThreadTest.c,v 1.22 2005/10/08 14:42:45 dgp Exp $ */ #include "tclInt.h" +extern int Tcltest_Init( Tcl_Interp* ); + #ifdef TCL_THREADS /* * Each thread has an single instance of the following structure. There diff --git a/generic/tclTomMath.h b/generic/tclTomMath.h index 313b6a4..a807e10 100644 --- a/generic/tclTomMath.h +++ b/generic/tclTomMath.h @@ -9,7 +9,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclTomMath.h,v 1.3 2005/09/26 19:31:18 kennykb Exp $ + * RCS: @(#) $Id: tclTomMath.h,v 1.4 2005/10/08 14:42:45 dgp Exp $ */ #ifndef TCLTOMMATH_H @@ -72,10 +72,12 @@ void* TclBNCalloc( size_t, size_t ); #define fast_s_mp_sqr TclBN_fast_s_mp_sqr #define mp_add TclBN_mp_add #define mp_add_d TclBN_mp_add_d +#define mp_and TclBN_mp_and #define mp_clamp TclBN_mp_clamp #define mp_clear TclBN_mp_clear #define mp_clear_multi TclBN_mp_clear_multi #define mp_cmp TclBN_mp_cmp +#define mp_cmp_d TclBN_mp_cmp_d #define mp_cmp_mag TclBN_mp_cmp_mag #define mp_copy TclBN_mp_copy #define mp_count_bits TclBN_mp_count_bits @@ -85,6 +87,7 @@ void* TclBNCalloc( size_t, size_t ); #define mp_div_2d TclBN_mp_div_2d #define mp_div_3 TclBN_mp_div_3 #define mp_exch TclBN_mp_exch +#define mp_expt_d TclBN_mp_expt_d #define mp_grow TclBN_mp_grow #define mp_init TclBN_mp_init #define mp_init_copy TclBN_mp_init_copy @@ -100,16 +103,24 @@ void* TclBNCalloc( size_t, size_t ); #define mp_mul_2 TclBN_mp_mul_2 #define mp_mul_2d TclBN_mp_mul_2d #define mp_mul_d TclBN_mp_mul_d +#define mp_neg TclBN_mp_neg +#define mp_or TclBN_mp_or #define mp_radix_size TclBN_mp_radix_size #define mp_read_radix TclBN_mp_read_radix #define mp_rshd TclBN_mp_rshd +#define mp_shrink TclBN_mp_shrink #define mp_set TclBN_mp_set #define mp_sqr TclBN_mp_sqr +#define mp_sqrt TclBN_mp_sqrt #define mp_sub TclBN_mp_sub #define mp_sub_d TclBN_mp_sub_d +#define mp_to_unsigned_bin TclBN_mp_to_unsigned_bin +#define mp_to_unsigned_bin_n TclBN_mp_to_unsigned_bin_n #define mp_toom_mul TclBN_mp_toom_mul #define mp_toom_sqr TclBN_mp_toom_sqr #define mp_toradix_n TclBN_mp_toradix_n +#define mp_unsigned_bin_size TclBN_mp_unsigned_bin_size +#define mp_xor TclBN_mp_xor #define mp_zero TclBN_mp_zero #define s_mp_add TclBN_s_mp_add #define s_mp_mul_digs TclBN_s_mp_mul_digs diff --git a/generic/tclTomMathInterface.c b/generic/tclTomMathInterface.c index 89537b9..7eda5c3 100644 --- a/generic/tclTomMathInterface.c +++ b/generic/tclTomMathInterface.c @@ -11,7 +11,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclTomMathInterface.c,v 1.2 2005/05/10 18:34:51 kennykb Exp $ + * RCS: @(#) $Id: tclTomMathInterface.c,v 1.3 2005/10/08 14:42:45 dgp Exp $ */ #include "tclInt.h" @@ -141,3 +141,83 @@ TclBNInitBignumFromLong( mp_int* a, long initVal ) a->used = p - a->dp; } + +/* + *---------------------------------------------------------------------- + * + * TclBNInitBignumFromWideInt -- + * + * Allocate and initialize a 'bignum' from a Tcl_WideInt + * + * Results: + * None. + * + * Side effects: + * The 'bignum' is constructed. + * + *---------------------------------------------------------------------- + */ + +extern void +TclBNInitBignumFromWideInt(mp_int* a, + /* Bignum to initialize */ + Tcl_WideInt v) + /* Initial value */ +{ + if (v < (Tcl_WideInt)0) { + TclBNInitBignumFromWideUInt(a, (Tcl_WideUInt)(-v)); + mp_neg(a, a); + } else { + TclBNInitBignumFromWideUInt(a, (Tcl_WideUInt)v); + } +} + +/* + *---------------------------------------------------------------------- + * + * TclBNInitBignumFromWideUInt -- + * + * Allocate and initialize a 'bignum' from a Tcl_WideUInt + * + * Results: + * None. + * + * Side effects: + * The 'bignum' is constructed. + * + *---------------------------------------------------------------------- + */ + +extern void +TclBNInitBignumFromWideUInt(mp_int* a, + /* Bignum to initialize */ + Tcl_WideUInt v) + /* Initial value */ +{ + + int status; + mp_digit* p; + + /* + * Allocate enough memory to hold the largest possible Tcl_WideUInt + */ + + status = mp_init_size(a, ((CHAR_BIT * sizeof( Tcl_WideUInt ) + + DIGIT_BIT - 1) + / DIGIT_BIT)); + if (status != MP_OKAY) { + Tcl_Panic( "initialization failure in TclBNInitBignumFromWideUInt" ); + } + + a->sign = MP_ZPOS; + + /* Store the magnitude in the bignum. */ + + p = a->dp; + while ( v ) { + *p++ = (mp_digit) ( v & MP_MASK ); + v >>= MP_DIGIT_BIT; + } + a->used = p - a->dp; + +} diff --git a/generic/tclUtil.c b/generic/tclUtil.c index 1dd6fcb..7e9e35a 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -11,7 +11,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclUtil.c,v 1.65 2005/09/15 16:40:02 dgp Exp $ + * RCS: @(#) $Id: tclUtil.c,v 1.66 2005/10/08 14:42:45 dgp Exp $ */ #include "tclInt.h" @@ -19,26 +19,6 @@ #include <math.h> /* - * Define test for NaN - */ - -#ifdef _MSC_VER -#define IS_NAN(f) (_isnan((f))) -#else -#define IS_NAN(f) ((f) != (f)) -#endif - -/* - * Define test for Inf - */ - -#ifdef _MSC_VER -#define IS_INF(f) ( ! (_finite((f)))) -#else -#define IS_INF(f) ( (f) > DBL_MAX || (f) < -DBL_MAX ) -#endif - -/* * The absolute pathname of the executable in which this Tcl library * is running. */ @@ -87,6 +67,8 @@ static void FreeProcessGlobalValue _ANSI_ARGS_(( ClientData clientData)); static void FreeThreadHash _ANSI_ARGS_((ClientData clientData)); static Tcl_HashTable * GetThreadHash _ANSI_ARGS_((Tcl_ThreadDataKey *keyPtr)); +static int ParseInteger _ANSI_ARGS_((CONST char *bytes, + int numBytes)); static int SetEndOffsetFromAny _ANSI_ARGS_((Tcl_Interp* interp, Tcl_Obj* objPtr)); static void UpdateStringOfEndOffset _ANSI_ARGS_((Tcl_Obj* objPtr)); @@ -1906,7 +1888,7 @@ Tcl_PrintDouble(interp, value, dst) * Handle NaN. */ - if (IS_NAN(value)) { + if (TclIsNaN(value)) { TclFormatNaN(value, dst); return; } @@ -1915,7 +1897,7 @@ Tcl_PrintDouble(interp, value, dst) * Handle infinities. */ - if (IS_INF(value)) { + if (TclIsInfinite(value)) { if (value < 0) { strcpy(dst, "-Inf"); } else { @@ -2175,6 +2157,7 @@ TclNeedSpace(start, end) } return 1; } +#if 0 /* *---------------------------------------------------------------------- @@ -2228,6 +2211,61 @@ TclLooksLikeInt(bytes, length) return (0 != TclParseInteger(p, length)); } +#endif + +/* + *---------------------------------------------------------------------- + * + * ParseInteger -- + * + * Scans up to numBytes bytes starting at bytes, and checks whether the + * leading bytes look like an integer's string representation. + * + * Results: + * Returns 0 if the leading bytes do not look like an integer. + * Otherwise, returns the number of bytes examined that look like an + * integer. This may be less than numBytes if the integer is only the + * leading part of the string. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +ParseInteger(bytes, numBytes) + CONST char *bytes; /* The string to examine. */ + int numBytes; /* Max number of bytes to scan. */ +{ + register CONST char *p = bytes; + + /* Take care of introductory "0x". */ + if ((numBytes > 1) && (p[0] == '0') && ((p[1] == 'x') || (p[1] == 'X'))) { + int scanned; + Tcl_UniChar ch; + + p += 2; + numBytes -= 2; + scanned = TclParseHex(p, numBytes, &ch); + if (scanned) { + return scanned+2; + } + + /* Recognize the 0 as valid integer, but x is left behind. */ + return 1; + } + while (numBytes && isdigit(UCHAR(*p))) { /* INTL: digit */ + numBytes--; p++; + } + if (numBytes == 0) { + return (p - bytes); + } + if ((*p != '.') && (*p != 'e') && (*p != 'E')) { + return (p - bytes); + } + return 0; +} /* *---------------------------------------------------------------------- @@ -2291,7 +2329,7 @@ TclGetIntForIndex(interp, objPtr, endValue, indexPtr) if ((*p == '+') || (*p == '-')) { p++; length--; } - opIdx = TclParseInteger(p, length) + (int) (p-bytes); + opIdx = ParseInteger(p, length) + (int) (p-bytes); if (opIdx) { int code, first, second; char savedOp = bytes[opIdx]; diff --git a/generic/tclVar.c b/generic/tclVar.c index 5e196a7..eddeb42 100644 --- a/generic/tclVar.c +++ b/generic/tclVar.c @@ -15,7 +15,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclVar.c,v 1.109 2005/07/23 00:04:32 dkf Exp $ + * RCS: @(#) $Id: tclVar.c,v 1.110 2005/10/08 14:42:45 dgp Exp $ */ #include "tclInt.h" @@ -1718,6 +1718,7 @@ TclPtrSetVar(interp, varPtr, arrayPtr, part1, part2, newValuePtr, flags) } return resultPtr; } +#if 0 /* *---------------------------------------------------------------------- @@ -1881,6 +1882,133 @@ TclPtrIncrVar(interp, varPtr, arrayPtr, part1, part2, incrAmount, flags) return TclPtrSetVar(interp, varPtr, arrayPtr, part1, part2, varValuePtr, flags); } +#endif + +/* + *---------------------------------------------------------------------- + * + * TclIncrObjVar2 -- + * + * Given a two-part variable name, which may refer either to a scalar + * variable or an element of an array, increment the Tcl object value of + * the variable by a specified Tcl_Obj increment value. + * + * Results: + * Returns a pointer to the Tcl_Obj holding the new value of the + * variable. If the specified variable doesn't exist, or there is a + * clash in array usage, or an error occurs while executing variable + * traces, then NULL is returned and a message will be left in the + * interpreter's result. + * + * Side effects: + * The value of the given variable is incremented by the specified + * amount. If either the array or the entry didn't exist then a new + * variable is created. The ref count for the returned object is _not_ + * incremented to reflect the returned reference; if you want to keep a + * reference to the object you must increment its ref count yourself. + * + *---------------------------------------------------------------------- + */ + +Tcl_Obj * +TclIncrObjVar2(interp, part1Ptr, part2Ptr, incrPtr, flags) + Tcl_Interp *interp; /* Command interpreter in which variable is to + * be found. */ + Tcl_Obj *part1Ptr; /* Points to an object holding the name of an + * array (if part2 is non-NULL) or the name of + * a variable. */ + Tcl_Obj *part2Ptr; /* If non-null, points to an object holding + * the name of an element in the array + * part1Ptr. */ + Tcl_Obj *incrPtr; /* Amount to be added to variable. */ + int flags; /* Various flags that tell how to incr value: + * any of TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY, + * TCL_APPEND_VALUE, TCL_LIST_ELEMENT, + * TCL_LEAVE_ERR_MSG. */ +{ + Var *varPtr, *arrayPtr; + char *part1, *part2; + + part1 = TclGetString(part1Ptr); + part2 = ((part2Ptr == NULL)? NULL : TclGetString(part2Ptr)); + + varPtr = TclObjLookupVar(interp, part1Ptr, part2, flags, "read", + 0, 1, &arrayPtr); + if (varPtr == NULL) { + Tcl_AddObjErrorInfo(interp, + "\n (reading value of variable to increment)", -1); + return NULL; + } + return TclPtrIncrObjVar(interp, varPtr, arrayPtr, part1, part2, + incrPtr, flags); +} + +/* + *---------------------------------------------------------------------- + * + * TclPtrIncrObjVar -- + * + * Given the pointers to a variable and possible containing array, + * increment the Tcl object value of the variable by a Tcl_Obj increment. + * + * Results: + * Returns a pointer to the Tcl_Obj holding the new value of the + * variable. If the specified variable doesn't exist, or there is a + * clash in array usage, or an error occurs while executing variable + * traces, then NULL is returned and a message will be left in the + * interpreter's result. + * + * Side effects: + * The value of the given variable is incremented by the specified + * amount. If either the array or the entry didn't exist then a new + * variable is created. The ref count for the returned object is _not_ + * incremented to reflect the returned reference; if you want to keep a + * reference to the object you must increment its ref count yourself. + * + *---------------------------------------------------------------------- + */ + +Tcl_Obj * +TclPtrIncrObjVar(interp, varPtr, arrayPtr, part1, part2, incrPtr, flags) + Tcl_Interp *interp; /* Command interpreter in which variable is to + * be found. */ + Var *varPtr; + Var *arrayPtr; + CONST char *part1; /* Points to an object holding the name of an + * array (if part2 is non-NULL) or the name of + * a variable. */ + CONST char *part2; /* If non-null, points to an object holding + * the name of an element in the array + * part1Ptr. */ + Tcl_Obj *incrPtr; /* Increment value */ +/* TODO: Which of these flag values really make sense? */ + CONST int flags; /* Various flags that tell how to incr value: + * any of TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY, + * TCL_APPEND_VALUE, TCL_LIST_ELEMENT, + * TCL_LEAVE_ERR_MSG. */ +{ + register Tcl_Obj *varValuePtr, *newValuePtr = NULL; + int code; + + varValuePtr = TclPtrGetVar(interp, varPtr, arrayPtr, part1, part2, flags); + if (varValuePtr == NULL) { + Tcl_AddObjErrorInfo(interp, + "\n (reading value of variable to increment)", -1); + return NULL; + } + if (Tcl_IsShared(varValuePtr)) { + varValuePtr = Tcl_DuplicateObj(varValuePtr); + } + code = TclIncrObj(interp, varValuePtr, incrPtr); + Tcl_IncrRefCount(varValuePtr); + if (code == TCL_OK) { + newValuePtr = TclPtrSetVar(interp, varPtr, arrayPtr, part1, part2, + varValuePtr, flags); + } + Tcl_DecrRefCount(varValuePtr); + return newValuePtr; +} +#if 0 /* *---------------------------------------------------------------------- @@ -2038,6 +2166,7 @@ TclPtrIncrWideVar(interp, varPtr, arrayPtr, part1, part2, incrAmount, flags) return TclPtrSetVar(interp, varPtr, arrayPtr, part1, part2, varValuePtr, flags); } +#endif /* *---------------------------------------------------------------------- diff --git a/generic/tommath.h b/generic/tommath.h index 1eabf11..ed2b986 100644 --- a/generic/tommath.h +++ b/generic/tommath.h @@ -549,7 +549,7 @@ TOMMATH_STORAGE_CLASS int mp_to_unsigned_bin_n (mp_int * a, unsigned char *b, un TOMMATH_STORAGE_CLASS int mp_signed_bin_size(mp_int *a); TOMMATH_STORAGE_CLASS int mp_read_signed_bin(mp_int *a, const unsigned char *b, int c); -TOMMATH_STORAGE_CLASS int mp_to_signed_bin(mp_int *a, unsigned char *b); +TOMMATH_STORAGE_CLASS int mp_to_signed_bin(mp_int *a, unsigned char *b); TOMMATH_STORAGE_CLASS int mp_to_signed_bin_n (mp_int * a, unsigned char *b, unsigned long *outlen); TOMMATH_STORAGE_CLASS int mp_read_radix(mp_int *a, const char *str, int radix); @@ -603,6 +603,6 @@ extern const char *mp_s_rmap; /* $Source: /root/tcl/repos-to-convert/tcl/generic/tommath.h,v $ */ -/* $Revision: 1.3 $ */ -/* $Date: 2005/09/26 18:44:06 $ */ +/* $Revision: 1.4 $ */ +/* $Date: 2005/10/08 14:42:45 $ */ diff --git a/libtommath/bn_mp_add_d.c b/libtommath/bn_mp_add_d.c index fde3cee..d472353 100644 --- a/libtommath/bn_mp_add_d.c +++ b/libtommath/bn_mp_add_d.c @@ -37,8 +37,9 @@ mp_add_d (mp_int * a, mp_digit b, mp_int * c) /* c = |a| - b */ res = mp_sub_d(a, b, c); - /* fix sign */ - a->sign = c->sign = MP_NEG; + /* fix signs */ + a->sign = MP_NEG; + c->sign = (c->used) ? MP_NEG : MP_ZPOS; return res; } @@ -105,5 +106,5 @@ mp_add_d (mp_int * a, mp_digit b, mp_int * c) #endif /* $Source: /root/tcl/repos-to-convert/tcl/libtommath/bn_mp_add_d.c,v $ */ -/* $Revision: 1.1.1.2 $ */ -/* $Date: 2005/09/26 16:31:56 $ */ +/* $Revision: 1.2 $ */ +/* $Date: 2005/10/08 14:42:54 $ */ diff --git a/tests/binary.test b/tests/binary.test index 2bd3169..e2ad12e 100644 --- a/tests/binary.test +++ b/tests/binary.test @@ -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: binary.test,v 1.24 2005/09/27 15:35:50 dkf Exp $ +# RCS: @(#) $Id: binary.test,v 1.25 2005/10/08 14:42:54 dgp Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest @@ -2141,6 +2141,66 @@ proc testIEEE {} { testConstraint ieeeFloatingPoint [testIEEE] +# scan/format infinities + +test binary-62.1 {infinity} ieeeFloatingPoint { + binary scan [binary format q Infinity] w w + format 0x%016lx $w +} 0x7ff0000000000000 +test binary-62.2 {infinity} ieeeFloatingPoint { + binary scan [binary format q -Infinity] w w + format 0x%016lx $w +} 0xfff0000000000000 +test binary-62.3 {infinity} ieeeFloatingPoint { + binary scan [binary format q Inf] w w + format 0x%016lx $w +} 0x7ff0000000000000 +test binary-62.4 {infinity} ieeeFloatingPoint { + binary scan [binary format q -Infinity] w w + format 0x%016lx $w +} 0xfff0000000000000 +test binary-62.5 {infinity} ieeeFloatingPoint { + binary scan [binary format w 0x7ff0000000000000] q d + set d +} Inf +test binary-62.6 {infinity} ieeeFloatingPoint { + binary scan [binary format w 0xfff0000000000000] q d + set d +} -Inf + +# scan/format Not-a-Number + +test binary-63.1 {NaN} ieeeFloatingPoint { + binary scan [binary format q NaN] w w + format 0x%016lx [expr {$w & 0xfff3ffffffffffff}] +} 0x7ff0000000000000 +test binary-63.2 {NaN} ieeeFloatingPoint { + binary scan [binary format q -NaN] w w + format 0x%016lx [expr {$w & 0xfff3ffffffffffff}] +} 0xfff0000000000000 +test binary-63.3 {NaN} ieeeFloatingPoint { + binary scan [binary format q NaN(3123456789aBc)] w w + format 0x%016lx [expr {$w & 0xfff3ffffffffffff}] +} 0x7ff3123456789abc +test binary-63.4 {NaN} ieeeFloatingPoint { + binary scan [binary format q {NaN( 3123456789aBc)}] w w + format 0x%016lx [expr {$w & 0xfff3ffffffffffff}] +} 0x7ff3123456789abc +test binary-64.1 {NaN} \ + -constraints ieeeFloatingPoint \ + -body { + binary scan [binary format w 0x7ff8000000000000] q d + set d + } \ + -match glob -result NaN* +test binary-64.2 {NaN} \ + -constraints ieeeFloatingPoint \ + -body { + binary scan [binary format w 0x7ff0123456789aBc] q d + set d + } \ + -match glob -result NaN(*123456789abc) + test binary-65.1 {largest significand} ieeeFloatingPoint { binary scan [binary format w 0x3fcfffffffffffff] q d set d @@ -2178,7 +2238,10 @@ test binary-65.8 {largest significand} ieeeFloatingPoint { set d } 18014398509481988.0 - # cleanup ::tcltest::cleanupTests return + +# Local Variables: +# mode: tcl +# End: diff --git a/tests/dict.test b/tests/dict.test index 090142e..1733424 100644 --- a/tests/dict.test +++ b/tests/dict.test @@ -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: dict.test,v 1.13 2005/07/21 21:49:08 dkf Exp $ +# RCS: @(#) $Id: dict.test,v 1.14 2005/10/08 14:42:54 dgp Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 @@ -317,6 +317,13 @@ test dict-11.16 {dict incr command: compilation} { } dicttest } {1 1 2 3} +test dict-11.17 {dict incr command: compilation} { + proc dicttest {} { + set dictv {a 1} + dict incr dictv a 2 + } + dicttest +} {a 3} test dict-12.1 {dict lappend command} { set dictv {a a} diff --git a/tests/expr-old.test b/tests/expr-old.test index bb5a4fd..28b4abb 100644 --- a/tests/expr-old.test +++ b/tests/expr-old.test @@ -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: expr-old.test,v 1.27 2005/09/29 23:16:29 hobbs Exp $ +# RCS: @(#) $Id: expr-old.test,v 1.28 2005/10/08 14:42:54 dgp Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2.1 @@ -1018,7 +1018,9 @@ test expr-old-36.16 {ExprLooksLikeInt procedure} { } {1 {can't use integer value too large to represent as operand of "+"}} testConstraint testexprlong [llength [info commands testexprlong]] +testConstraint testexprdouble [llength [info commands testexprdouble]] testConstraint testexprstring [llength [info commands testexprstring]] +testConstraint longIs32bit [expr {int(0x80000000) < 0}] test expr-old-37.1 {Check that Tcl_ExprLong doesn't modify interpreter result if no error} testexprlong { testexprlong 4+1 @@ -1028,6 +1030,98 @@ test expr-old-37.2 {Tcl_ExprLong handles wide ints gracefully} testexprlong { testexprlong wide(1)+2 } {This is a result: 3} +test expr-old-37.3 {Tcl_ExprLong on the empty string} testexprlong { + testexprlong "" +} {This is a result: 0} +test expr-old-37.4 {Tcl_ExprLong coerces doubles} testexprlong { + testexprlong 3+.14159 +} {This is a result: 3} +test expr-old-37.5 {Tcl_ExprLong handles overflows} {testexprlong longIs32bit} { + testexprlong 0x80000000 +} {This is a result: -2147483648} +test expr-old-37.6 {Tcl_ExprLong handles overflows} {testexprlong longIs32bit} { + testexprlong 0xffffffff +} {This is a result: -1} +test expr-old-37.7 {Tcl_ExprLong handles overflows} \ + -constraints {testexprlong longIs32bit} \ + -match glob \ + -body { + list [catch {testexprlong 0x100000000} result] $result + } \ + -result {1 {integer value too large to represent*}} +test expr-old-37.8 {Tcl_ExprLong handles overflows} testexprlong { + testexprlong -0x80000000 +} {This is a result: -2147483648} +test expr-old-37.9 {Tcl_ExprLong handles overflows} {testexprlong longIs32bit} { + testexprlong -0xffffffff +} {This is a result: 1} +test expr-old-37.10 {Tcl_ExprLong handles overflows} \ + -constraints {testexprlong longIs32bit} \ + -match glob \ + -body { + list [catch {testexprlong -0x100000000} result] $result + } \ + -result {1 {integer value too large to represent*}} +test expr-old-37.11 {Tcl_ExprLong handles overflows} {testexprlong longIs32bit} { + testexprlong 2147483648. +} {This is a result: -2147483648} +test expr-old-37.12 {Tcl_ExprLong handles overflows} {testexprlong longIs32bit} { + testexprlong 4294967295. +} {This is a result: -1} +test expr-old-37.13 {Tcl_ExprLong handles overflows} \ + -constraints {testexprlong longIs32bit} \ + -match glob \ + -body { + list [catch {testexprlong 4294967296.} result] $result + } \ + -result {1 {integer value too large to represent*}} +test expr-old-37.14 {Tcl_ExprLong handles overflows} testexprlong { + testexprlong -2147483648. +} {This is a result: -2147483648} +test expr-old-37.15 {Tcl_ExprLong handles overflows} {testexprlong longIs32bit} { + testexprlong -4294967295. +} {This is a result: 1} +test expr-old-37.16 {Tcl_ExprLong handles overflows} \ + -constraints {testexprlong longIs32bit} \ + -match glob \ + -body { + list [catch {testexprlong 4294967296.} result] $result + } \ + -result {1 {integer value too large to represent*}} + +test expr-old-37.17 {Check that Tcl_ExprDouble doesn't modify interpreter result if no error} testexprdouble { + testexprdouble 4.+1. +} {This is a result: 5.0} +#Check for [Bug 1109484] +test expr-old-37.18 {Tcl_ExprDouble on the empty string} testexprdouble { + testexprdouble "" +} {This is a result: 0.0} +test expr-old-37.19 {Tcl_ExprDouble coerces wides} testexprdouble { + testexprdouble 1[string repeat 0 17] +} {This is a result: 1e+17} +test expr-old-37.20 {Tcl_ExprDouble coerces bignums} testexprdouble { + testexprdouble 1[string repeat 0 38] +} {This is a result: 1e+38} +test expr-old-37.21 {Tcl_ExprDouble handles overflows} testexprdouble { + testexprdouble 17976931348623157[string repeat 0 292]. +} {This is a result: 1.7976931348623157e+308} +test expr-old-37.22 {Tcl_ExprDouble handles overflows that look like int} \ + testexprdouble { + testexprdouble 17976931348623157[string repeat 0 292] + } {This is a result: 1.7976931348623157e+308} +test expr-old-37.23 {Tcl_ExprDouble handles overflows} \ + ieeeFloatingPoint&&testexprdouble { + testexprdouble 17976931348623165[string repeat 0 292]. + } {This is a result: Inf} +test expr-old-37.24 {Tcl_ExprDouble handles overflows that look like int} \ + ieeeFloatingPoint&&testexprdouble { + testexprdouble 17976931348623165[string repeat 0 292] + } {This is a result: Inf} +test expr-old-37.25 {Tcl_ExprDouble and NaN} \ + ieeeFloatingPoint&&testexprdouble { + list [catch {testexprdouble 0.0/0.0} result] $result + } {1 {floating point value is Not a Number}} + test expr-old-38.1 {Verify Tcl_ExprString's basic operation} testexprstring { list [testexprstring "1+4"] [testexprstring "2*3+4.2"] \ [catch {testexprstring "1+"} msg] $msg @@ -1109,3 +1203,7 @@ if {(4195835.0 - (4195835.0/3145727.0)*3145727.0) == 256.0} { # cleanup ::tcltest::cleanupTests return + +# Local Variables: +# mode: tcl +# End: diff --git a/tests/expr.test b/tests/expr.test index 50159c0..92308b9 100644 --- a/tests/expr.test +++ b/tests/expr.test @@ -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: expr.test,v 1.44 2005/08/29 17:54:22 kennykb Exp $ +# RCS: @(#) $Id: expr.test,v 1.45 2005/10/08 14:42:54 dgp Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2.1 @@ -26,7 +26,8 @@ testConstraint testmathfunctions [expr { testConstraint longIs32bit [expr {int(0x80000000) < 0}] testConstraint longIs64bit [expr {int(0x8000000000000000) < 0}] -testConstraint wideIs64bit [expr {(0x80000000 > 0) && (0x8000000000000000 < 0)}] +testConstraint wideIs64bit \ + [expr {(wide(0x80000000) > 0) && (wide(0x8000000000000000) < 0)}] # Big test for correct ordering of data in [expr] @@ -54,6 +55,8 @@ proc testIEEE {} { ieeeValues(+Infinity) binary scan \x00\x00\x00\x00\x00\x00\xf8\x7f d \ ieeeValues(NaN) + binary scan \x00\x00\x00\x00\x00\x00\xf8\xff d \ + ieeeValues(-NaN) set ieeeValues(littleEndian) 1 return 1 } @@ -76,6 +79,8 @@ proc testIEEE {} { ieeeValues(+Infinity) binary scan \x7f\xf8\x00\x00\x00\x00\x00\x00 d \ ieeeValues(NaN) + binary scan \xff\xf8\x00\x00\x00\x00\x00\x00 d \ + ieeeValues(-NaN) set ieeeValues(littleEndian) 0 return 1 } @@ -6239,6 +6244,245 @@ test expr-38.1 {abs of smallest 32-bit integer [Bug 1241572]} {wideIs64bit} { expr {abs(-2147483648)} } 2147483648 +testConstraint testexprlongobj [llength [info commands testexprlongobj]] +testConstraint testexprdoubleobj [llength [info commands testexprdoubleobj]] + +test expr-39.1 {Check that Tcl_ExprLongObj doesn't modify interpreter result if no error} testexprlongobj { + testexprlongobj 4+1 +} {This is a result: 5} +#Check for [Bug 1109484] +test expr-39.2 {Tcl_ExprLongObj handles wide ints gracefully} testexprlongobj { + testexprlongobj wide(1)+2 +} {This is a result: 3} + +test expr-39.3 {Tcl_ExprLongObj on the empty string} \ + -constraints testexprlongobj \ + -body { + list [catch {testexprlongobj ""} result] $result + } \ + -match glob \ + -result {1 {syntax error*}} +test expr-39.4 {Tcl_ExprLongObj coerces doubles} testexprlongobj { + testexprlongobj 3+.14159 +} {This is a result: 3} +test expr-39.5 {Tcl_ExprLongObj handles overflows} {testexprlongobj longIs32bit} { + testexprlongobj 0x80000000 +} {This is a result: -2147483648} +test expr-39.6 {Tcl_ExprLongObj handles overflows} {testexprlongobj longIs32bit} { + testexprlongobj 0xffffffff +} {This is a result: -1} +test expr-39.7 {Tcl_ExprLongObj handles overflows} \ + -constraints {testexprlongobj longIs32bit} \ + -match glob \ + -body { + list [catch {testexprlongobj 0x100000000} result] $result + } \ + -result {1 {integer value too large to represent*}} +test expr-39.8 {Tcl_ExprLongObj handles overflows} testexprlongobj { + testexprlongobj -0x80000000 +} {This is a result: -2147483648} +test expr-39.9 {Tcl_ExprLongObj handles overflows} {testexprlongobj longIs32bit} { + testexprlongobj -0xffffffff +} {This is a result: 1} +test expr-39.10 {Tcl_ExprLongObj handles overflows} \ + -constraints {testexprlongobj longIs32bit} \ + -match glob \ + -body { + list [catch {testexprlongobj -0x100000000} result] $result + } \ + -result {1 {integer value too large to represent*}} +test expr-39.11 {Tcl_ExprLongObj handles overflows} {testexprlongobj longIs32bit} { + testexprlongobj 2147483648. +} {This is a result: -2147483648} +test expr-39.12 {Tcl_ExprLongObj handles overflows} {testexprlongobj longIs32bit} { + testexprlongobj 4294967295. +} {This is a result: -1} +test expr-39.13 {Tcl_ExprLongObj handles overflows} \ + -constraints {testexprlongobj longIs32bit} \ + -match glob \ + -body { + list [catch {testexprlongobj 4294967296.} result] $result + } \ + -result {1 {integer value too large to represent*}} +test expr-39.14 {Tcl_ExprLongObj handles overflows} testexprlongobj { + testexprlongobj -2147483648. +} {This is a result: -2147483648} +test expr-39.15 {Tcl_ExprLongObj handles overflows} {testexprlongobj longIs32bit} { + testexprlongobj -4294967295. +} {This is a result: 1} +test expr-39.16 {Tcl_ExprLongObj handles overflows} \ + -constraints {testexprlongobj longIs32bit} \ + -match glob \ + -body { + list [catch {testexprlongobj 4294967296.} result] $result + } \ + -result {1 {integer value too large to represent*}} + +test expr-39.17 {Check that Tcl_ExprDoubleObj doesn't modify interpreter result if no error} testexprdoubleobj { + testexprdoubleobj 4.+1. +} {This is a result: 5.0} +#Check for [Bug 1109484] +test expr-39.18 {Tcl_ExprDoubleObj on the empty string} \ + -constraints testexprdoubleobj \ + -match glob \ + -body { + list [catch {testexprdoubleobj ""} result] $result + } \ + -result {1 {syntax error*}} +test expr-39.19 {Tcl_ExprDoubleObj coerces wides} testexprdoubleobj { + testexprdoubleobj 1[string repeat 0 17] +} {This is a result: 1e+17} +test expr-39.20 {Tcl_ExprDoubleObj coerces bignums} testexprdoubleobj { + testexprdoubleobj 1[string repeat 0 38] +} {This is a result: 1e+38} +test expr-39.21 {Tcl_ExprDoubleObj handles overflows} \ + testexprdoubleobj&&ieeeFloatingPoint { + testexprdoubleobj 17976931348623157[string repeat 0 292]. + } {This is a result: 1.7976931348623157e+308} +test expr-39.22 {Tcl_ExprDoubleObj handles overflows that look like int} \ + testexprdoubleobj&&ieeeFloatingPoint { + testexprdoubleobj 17976931348623157[string repeat 0 292] + } {This is a result: 1.7976931348623157e+308} +test expr-39.23 {Tcl_ExprDoubleObj handles overflows} \ + testexprdoubleobj&&ieeeFloatingPoint { + testexprdoubleobj 17976931348623165[string repeat 0 292]. + } {This is a result: Inf} +test expr-39.24 {Tcl_ExprDoubleObj handles overflows that look like int} \ + testexprdoubleobj&&ieeeFloatingPoint { + testexprdoubleobj 17976931348623165[string repeat 0 292] + } {This is a result: Inf} +test expr-39.25 {Tcl_ExprDoubleObj and NaN} \ + testexprdoubleobj&&ieeeFloatingPoint { + list [catch {testexprdoubleobj 0.0/0.0} result] $result + } {1 {floating point value is Not a Number}} + +test expr-40.1 {large octal shift} { + expr 0100000000000000000000000000000000 +} [expr 0x1000000000000000000000000] +test expr-40.2 {large octal shift} { + expr 0100000000000000000000000000000001 +} [expr 0x1000000000000000000000001] + +test expr-41.1 {exponent overflow} { + expr 1.0e2147483630 +} Inf +test expr-41.2 {exponent underflow} { + expr 1.0e-2147483630 +} 0.0 + +test expr-42.1 {denormals} ieeeFloatingPoint { + expr 7e-324 +} 5e-324 + +# TIP 114 + +test expr-43.1 {0b notation} { + expr 0b0 +} 0 +test expr-43.2 {0b notation} { + expr 0b1 +} 1 +test expr-43.3 {0b notation} { + expr 0b10 +} 2 +test expr-43.4 {0b notation} { + expr 0b11 +} 3 +test expr-43.5 {0b notation} { + expr 0b100 +} 4 +test expr-43.6 {0b notation} { + expr 0b101 +} 5 +test expr-43.7 {0b notation} { + expr 0b1000 +} 8 +test expr-43.8 {0b notation} { + expr 0b1001 +} 9 +test expr-43.9 {0b notation} { + expr 0b1[string repeat 0 31] +} 2147483648 +test expr-43.10 {0b notation} { + expr 0b1[string repeat 0 30]1 +} 2147483649 +test expr-43.11 {0b notation} { + expr 0b[string repeat 1 64] +} 18446744073709551615 +test expr-43.12 {0b notation} { + expr 0b1[string repeat 0 64] +} 18446744073709551616 +test expr-43.13 {0b notation} { + expr 0b1[string repeat 0 63]1 +} 18446744073709551617 + +test expr-44.1 {0o notation} { + expr 0o0 +} 0 +test expr-44.2 {0o notation} { + expr 0o1 +} 1 +test expr-44.3 {0o notation} { + expr 0o7 +} 7 +test expr-44.4 {0o notation} { + expr 0o10 +} 8 +test expr-44.5 {0o notation} { + expr 0o11 +} 9 +test expr-44.6 {0o notation} { + expr 0o100 +} 64 +test expr-44.7 {0o notation} { + expr 0o101 +} 65 +test expr-44.8 {0o notation} { + expr 0o1000 +} 512 +test expr-44.9 {0o notation} { + expr 0o1001 +} 513 +test expr-44.10 {0o notation} { + expr 0o1[string repeat 7 21] +} 18446744073709551615 +test expr-44.11 {0o notation} { + expr 0o2[string repeat 0 21] +} 18446744073709551616 +test expr-44.12 {0o notation} { + expr 0o2[string repeat 0 20]1 +} 18446744073709551617 + +# TIP 237 again + +test expr-45.1 {entier} { + expr entier(0) +} 0 +test expr-45.2 {entier} { + expr entier(0.5) +} 0 +test expr-45.3 {entier} { + expr entier(1.0) +} 1 +test expr-45.4 {entier} { + expr entier(1.5) +} 1 +test expr-45.5 {entier} { + expr entier(2.0) +} 2 +test expr-45.6 {entier} { + expr entier(1e+22) +} 10000000000000000000000 +test expr-45.7 {entier} { + list [catch {expr entier(Inf)} result] $result +} {1 {integer value too large to represent}} +test expr-45.8 {entier} ieeeFloatingPoint { + list [catch {expr {entier($ieeeValues(NaN))}} result] $result +} {1 {floating point value is Not a Number}} +test expr-45.9 {entier} ieeeFloatingPoint { + list [catch {expr {entier($ieeeValues(-NaN))}} result] $result +} {1 {floating point value is Not a Number}} + test expr-46.1 {round() rounds to +-infinity} { expr round(0.5) } 1 diff --git a/tests/format.test b/tests/format.test index a6e2242..86f4665 100644 --- a/tests/format.test +++ b/tests/format.test @@ -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: format.test,v 1.21 2005/07/28 18:42:32 dgp Exp $ +# RCS: @(#) $Id: format.test,v 1.22 2005/10/08 14:42:54 dgp Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 @@ -504,7 +504,7 @@ for {set i 290} {$i < 400} {incr i} { } ::tcltest::testConstraint wideIs64bit \ - [expr {(0x80000000 > 0) && (0x8000000000000000 < 0)}] + [expr {(wide(0x80000000) > 0) && (wide(0x8000000000000000) < 0)}] ::tcltest::testConstraint wideBiggerThanInt \ [expr {wide(0x80000000) != int(0x80000000)}] diff --git a/tests/obj.test b/tests/obj.test index e905698..51c9e43 100644 --- a/tests/obj.test +++ b/tests/obj.test @@ -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: obj.test,v 1.18 2005/07/28 18:42:32 dgp Exp $ +# RCS: @(#) $Id: obj.test,v 1.19 2005/10/08 14:42:54 dgp Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest @@ -26,18 +26,14 @@ test obj-1.1 {Tcl_AppendAllObjTypes, and InitTypeTable, Tcl_RegisterObjType} tes set r 1 foreach {t} { {array search} - bignum bytearray bytecode cmdName dict - double end-offset - int nsName regexp string - wideInt } { set first [string first $t [testobj types]] set r [expr {$r && ($first != -1)}] @@ -52,17 +48,19 @@ test obj-2.2 {Tcl_GetObjType and Tcl_ConvertToType} testobj { set result "" lappend result [testobj freeallvars] lappend result [testintobj set 1 12] - lappend result [testobj convert 1 double] + lappend result [testobj convert 1 bytearray] lappend result [testobj type 1] lappend result [testobj refcount 1] -} {{} 12 12 double 3} +} {{} 12 12 bytearray 3} test obj-3.1 {Tcl_ConvertToType error} testobj { - list [testdoubleobj set 1 12.34] [catch {testobj convert 1 int} msg] $msg -} {12.34 1 {expected integer but got "12.34"}} + list [testdoubleobj set 1 12.34] \ + [catch {testobj convert 1 end-offset} msg] \ + $msg +} {12.34 1 {bad index "12.34": must be end?[+-]integer?}} test obj-3.2 {Tcl_ConvertToType error, "empty string" object} testobj { - list [testobj newobj 1] [catch {testobj convert 1 int} msg] $msg -} {{} 1 {expected integer but got ""}} + list [testobj newobj 1] [catch {testobj convert 1 end-offset} msg] $msg +} {{} 1 {bad index "": must be end?[+-]integer?}} test obj-4.1 {Tcl_NewObj and AllocateFreeObjects} testobj { set result "" diff --git a/tests/scan.test b/tests/scan.test index 2bb6626..97c6d04 100644 --- a/tests/scan.test +++ b/tests/scan.test @@ -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: scan.test,v 1.17 2005/07/28 18:42:33 dgp Exp $ +# RCS: @(#) $Id: scan.test,v 1.18 2005/10/08 14:42:54 dgp Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 @@ -19,7 +19,7 @@ if {[lsearch [namespace children] ::tcltest] == -1} { } ::tcltest::testConstraint wideIs64bit \ - [expr {(0x80000000 > 0) && (0x8000000000000000 < 0)}] + [expr {(wide(0x80000000) > 0) && (wide(0x8000000000000000) < 0)}] test scan-1.1 {BuildCharSet, CharInSet} { list [scan foo {%[^o]} x] $x @@ -341,9 +341,10 @@ test scan-4.61 {Tcl_ScanObjCmd, set errors} { # procedure that returns the range of integers proc int_range {} { - for { set MIN_INT 1 } { $MIN_INT > 0 } {} { + for { set MIN_INT 1 } { int($MIN_INT) > 0 } {} { set MIN_INT [expr { $MIN_INT << 1 }] } + set MIN_INT [expr {int($MIN_INT)}] set MAX_INT [expr { ~ $MIN_INT }] return [list $MIN_INT $MAX_INT] } @@ -679,6 +680,82 @@ test scan-13.8 {Tcl_ScanObjCmd, inline XPG case lots of arguments} { list [llength $msg] [lindex $msg 99] [lindex $msg 4] [lindex $msg 199] } {200 10 20 30} +# Big test for correct ordering of data in [expr] + +proc testIEEE {} { + variable ieeeValues + binary scan [binary format dd -1.0 1.0] c* c + switch -exact -- $c { + {0 0 0 0 0 0 -16 -65 0 0 0 0 0 0 -16 63} { + # little endian + binary scan \x00\x00\x00\x00\x00\x00\xf0\xff d \ + ieeeValues(-Infinity) + binary scan \x00\x00\x00\x00\x00\x00\xf0\xbf d \ + ieeeValues(-Normal) + binary scan \x00\x00\x00\x00\x00\x00\x08\x80 d \ + ieeeValues(-Subnormal) + binary scan \x00\x00\x00\x00\x00\x00\x00\x80 d \ + ieeeValues(-0) + binary scan \x00\x00\x00\x00\x00\x00\x00\x00 d \ + ieeeValues(+0) + binary scan \x00\x00\x00\x00\x00\x00\x08\x00 d \ + ieeeValues(+Subnormal) + binary scan \x00\x00\x00\x00\x00\x00\xf0\x3f d \ + ieeeValues(+Normal) + binary scan \x00\x00\x00\x00\x00\x00\xf0\x7f d \ + ieeeValues(+Infinity) + binary scan \x00\x00\x00\x00\x00\x00\xf8\x7f d \ + ieeeValues(NaN) + set ieeeValues(littleEndian) 1 + return 1 + } + {-65 -16 0 0 0 0 0 0 63 -16 0 0 0 0 0 0} { + binary scan \xff\xf0\x00\x00\x00\x00\x00\x00 d \ + ieeeValues(-Infinity) + binary scan \xbf\xf0\x00\x00\x00\x00\x00\x00 d \ + ieeeValues(-Normal) + binary scan \x80\x08\x00\x00\x00\x00\x00\x00 d \ + ieeeValues(-Subnormal) + binary scan \x80\x00\x00\x00\x00\x00\x00\x00 d \ + ieeeValues(-0) + binary scan \x00\x00\x00\x00\x00\x00\x00\x00 d \ + ieeeValues(+0) + binary scan \x00\x08\x00\x00\x00\x00\x00\x00 d \ + ieeeValues(+Subnormal) + binary scan \x3f\xf0\x00\x00\x00\x00\x00\x00 d \ + ieeeValues(+Normal) + binary scan \x7f\xf0\x00\x00\x00\x00\x00\x00 d \ + ieeeValues(+Infinity) + binary scan \x7f\xf8\x00\x00\x00\x00\x00\x00 d \ + ieeeValues(NaN) + set ieeeValues(littleEndian) 0 + return 1 + } + default { + return 0 + } + } +} + +testConstraint ieeeFloatingPoint [testIEEE] + +# scan infinities - not working + +test scan-14.1 {infinity} ieeeFloatingPoint { + scan Inf %g d + set d +} Inf +test scan-14.2 {infinity} ieeeFloatingPoint { + scan -Inf %g d + set d +} -Inf + +# TODO - also need to scan NaN's + # cleanup ::tcltest::cleanupTests return + +# Local Variables: +# mode: tcl +# End:
\ No newline at end of file diff --git a/tests/string.test b/tests/string.test index 2402657..1969c59 100644 --- a/tests/string.test +++ b/tests/string.test @@ -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: string.test,v 1.51 2005/07/28 18:42:33 dgp Exp $ +# RCS: @(#) $Id: string.test,v 1.52 2005/10/08 14:42:54 dgp Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest @@ -293,7 +293,7 @@ proc largest_int {} { # so we can test for overflow properly below on >32 bit systems set int 1 set exp 7; # assume we get at least 8 bits - while {$int > 0} { set int [expr {wide(1) << [incr exp]}] } + while {wide($int) > 0} { set int [expr {wide(1) << [incr exp]}] } return [expr {$int-1}] } diff --git a/unix/Makefile.in b/unix/Makefile.in index a66fb08..f68afa2 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -5,7 +5,7 @@ # "autoconf" program (constructs like "@foo@" will get replaced in the # actual Makefile. # -# RCS: @(#) $Id: Makefile.in,v 1.173 2005/08/24 17:56:24 andreas_kupries Exp $ +# RCS: @(#) $Id: Makefile.in,v 1.174 2005/10/08 14:42:54 dgp Exp $ VERSION = @TCL_VERSION@ MAJOR_VERSION = @TCL_MAJOR_VERSION@ @@ -275,13 +275,14 @@ DDD = ddd CC_SWITCHES = ${CFLAGS} ${CFLAGS_WARNING} ${SHLIB_CFLAGS} \ --I${BUILD_DIR} -I${UNIX_DIR} -I${GENERIC_DIR} -DTCL_TOMMATH -I${TOMMATH_DIR} \ -${AC_FLAGS} ${GENERIC_FLAGS} ${PROTO_FLAGS} \ +-I${BUILD_DIR} -I${UNIX_DIR} -I${GENERIC_DIR} -DTCL_TOMMATH -DMP_PREC=4 \ +-I${TOMMATH_DIR} ${AC_FLAGS} ${GENERIC_FLAGS} ${PROTO_FLAGS} \ ${NO_DEPRECATED_FLAGS} ${ENV_FLAGS} @EXTRA_CC_SWITCHES@ STUB_CC_SWITCHES = ${CFLAGS} ${CFLAGS_WARNING} ${SHLIB_CFLAGS} \ --I${BUILD_DIR} -I${UNIX_DIR} -I${GENERIC_DIR} -DTCL_TOMMATH -I${TOMMATH_DIR} \ -${AC_FLAGS} ${GENERIC_FLAGS} ${PROTO_FLAGS} ${ENV_FLAGS} @EXTRA_CC_SWITCHES@ +-I${BUILD_DIR} -I${UNIX_DIR} -I${GENERIC_DIR} -DTCL_TOMMATH -DMP_PREC=4 \ +-I${TOMMATH_DIR} ${AC_FLAGS} ${GENERIC_FLAGS} ${PROTO_FLAGS} ${ENV_FLAGS} \ +@EXTRA_CC_SWITCHES@ LIBS = @TCL_LIBS@ @@ -314,20 +315,23 @@ GENERIC_OBJS = regcomp.o regexec.o regfree.o regerror.o tclAlloc.o \ tclTomMathInterface.o TOMMATH_OBJS = bncore.o bn_reverse.o bn_fast_s_mp_mul_digs.o \ - bn_fast_s_mp_sqr.o bn_mp_add.o \ + bn_fast_s_mp_sqr.o bn_mp_add.o bn_mp_and.o \ bn_mp_add_d.o bn_mp_clamp.o bn_mp_clear.o bn_mp_clear_multi.o \ - bn_mp_cmp.o bn_mp_cmp_mag.o bn_mp_copy.o bn_mp_count_bits.o \ - bn_mp_div.o bn_mp_div_d.o bn_mp_div_2.o bn_mp_div_2d.o bn_mp_div_3.o \ - bn_mp_exch.o bn_mp_grow.o bn_mp_init.o bn_mp_init_copy.o \ - bn_mp_init_multi.o bn_mp_init_set.o \ + bn_mp_cmp.o bn_mp_cmp_d.o bn_mp_cmp_mag.o bn_mp_copy.o \ + bn_mp_count_bits.o bn_mp_div.o bn_mp_div_d.o bn_mp_div_2.o \ + bn_mp_div_2d.o bn_mp_div_3.o \ + bn_mp_exch.o bn_mp_expt_d.o bn_mp_grow.o bn_mp_init.o \ + bn_mp_init_copy.o bn_mp_init_multi.o bn_mp_init_set.o \ bn_mp_init_size.o bn_mp_karatsuba_mul.o \ bn_mp_karatsuba_sqr.o \ bn_mp_lshd.o bn_mp_mod.o bn_mp_mod_2d.o bn_mp_mul.o bn_mp_mul_2.o \ - bn_mp_mul_2d.o bn_mp_mul_d.o bn_mp_radix_size.o bn_mp_radix_smap.o \ - bn_mp_read_radix.o bn_mp_rshd.o bn_mp_set.o bn_mp_sqr.o \ - bn_mp_sub.o bn_mp_sub_d.o \ - bn_mp_toom_mul.o bn_mp_toom_sqr.o \ - bn_mp_toradix_n.o bn_mp_zero.o bn_s_mp_add.o \ + bn_mp_mul_2d.o bn_mp_mul_d.o bn_mp_neg.o bn_mp_or.o \ + bn_mp_radix_size.o bn_mp_radix_smap.o \ + bn_mp_read_radix.o bn_mp_rshd.o bn_mp_set.o bn_mp_shrink.o \ + bn_mp_sqr.o bn_mp_sqrt.o bn_mp_sub.o bn_mp_sub_d.o \ + bn_mp_to_unsigned_bin.o bn_mp_to_unsigned_bin_n.o \ + bn_mp_toom_mul.o bn_mp_toom_sqr.o bn_mp_toradix_n.o \ + bn_mp_unsigned_bin_size.o bn_mp_xor.o bn_mp_zero.o bn_s_mp_add.o \ bn_s_mp_mul_digs.o bn_s_mp_sqr.o bn_s_mp_sub.o STUB_LIB_OBJS = tclStubLib.o ${COMPAT_OBJS} @@ -436,10 +440,12 @@ TOMMATH_SRCS = \ $(TOMMATH_DIR)/bn_fast_s_mp_sqr.c \ $(TOMMATH_DIR)/bn_mp_add.c \ $(TOMMATH_DIR)/bn_mp_add_d.c \ + $(TOMMATH_DIR)/bn_mp_and.c \ $(TOMMATH_DIR)/bn_mp_clamp.c \ $(TOMMATH_DIR)/bn_mp_clear.c \ $(TOMMATH_DIR)/bn_mp_clear_multi.c \ $(TOMMATH_DIR)/bn_mp_cmp.c \ + $(TOMMATH_DIR)/bn_mp_cmp_d.c \ $(TOMMATH_DIR)/bn_mp_cmp_mag.c \ $(TOMMATH_DIR)/bn_mp_copy.c \ $(TOMMATH_DIR)/bn_mp_count_bits.c \ @@ -449,6 +455,7 @@ TOMMATH_SRCS = \ $(TOMMATH_DIR)/bn_mp_div_2d.c \ $(TOMMATH_DIR)/bn_mp_div_3.c \ $(TOMMATH_DIR)/bn_mp_exch.c \ + $(TOMMATH_DIR)/bn_mp_expt_d.c \ $(TOMMATH_DIR)/bn_mp_grow.c \ $(TOMMATH_DIR)/bn_mp_init.c \ $(TOMMATH_DIR)/bn_mp_init_copy.c \ @@ -464,17 +471,25 @@ TOMMATH_SRCS = \ $(TOMMATH_DIR)/bn_mp_mul_2.c \ $(TOMMATH_DIR)/bn_mp_mul_2d.c \ $(TOMMATH_DIR)/bn_mp_mul_d.c \ + $(TOMMATH_DIR)/bn_mp_neg.c \ + $(TOMMATH_DIR)/bn_mp_or.c \ $(TOMMATH_DIR)/bn_mp_radix_size.c \ $(TOMMATH_DIR)/bn_mp_radix_smap.c \ $(TOMMATH_DIR)/bn_mp_read_radix.c \ $(TOMMATH_DIR)/bn_mp_rshd.c \ $(TOMMATH_DIR)/bn_mp_set.c \ + $(TOMMATH_DIR)/bn_mp_shrink.c \ $(TOMMATH_DIR)/bn_mp_sqr.c \ + $(TOMMATH_DIR)/bn_mp_sqrt.c \ $(TOMMATH_DIR)/bn_mp_sub.c \ $(TOMMATH_DIR)/bn_mp_sub_d.c \ + $(TOMMATH_DIR)/bn_mp_to_unsigned_bin.c \ + $(TOMMATH_DIR)/bn_mp_to_unsigned_bin_n.c \ $(TOMMATH_DIR)/bn_mp_toom_mul.c \ $(TOMMATH_DIR)/bn_mp_toom_sqr.c \ $(TOMMATH_DIR)/bn_mp_toradix_n.c \ + $(TOMMATH_DIR)/bn_mp_unsigned_bin_size.c \ + $(TOMMATH_DIR)/bn_mp_xor.c \ $(TOMMATH_DIR)/bn_mp_zero.c \ $(TOMMATH_DIR)/bn_s_mp_add.c \ $(TOMMATH_DIR)/bn_s_mp_mul_digs.c \ @@ -1194,6 +1209,9 @@ bn_mp_add.o: $(TOMMATH_DIR)/bn_mp_add.c bn_mp_add_d.o: $(TOMMATH_DIR)/bn_mp_add_d.c $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_add_d.c +bn_mp_and.o: $(TOMMATH_DIR)/bn_mp_and.c + $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_and.c + bn_mp_clamp.o: $(TOMMATH_DIR)/bn_mp_clamp.c $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_clamp.c @@ -1206,6 +1224,9 @@ bn_mp_clear_multi.o: $(TOMMATH_DIR)/bn_mp_clear_multi.c bn_mp_cmp.o: $(TOMMATH_DIR)/bn_mp_cmp.c $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_cmp.c +bn_mp_cmp_d.o: $(TOMMATH_DIR)/bn_mp_cmp_d.c + $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_cmp_d.c + bn_mp_cmp_mag.o: $(TOMMATH_DIR)/bn_mp_cmp_mag.c $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_cmp_mag.c @@ -1233,6 +1254,9 @@ bn_mp_div_3.o: $(TOMMATH_DIR)/bn_mp_div_3.c bn_mp_exch.o: $(TOMMATH_DIR)/bn_mp_exch.c $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_exch.c +bn_mp_expt_d.o: $(TOMMATH_DIR)/bn_mp_expt_d.c + $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_expt_d.c + bn_mp_grow.o: $(TOMMATH_DIR)/bn_mp_grow.c $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_grow.c @@ -1278,6 +1302,12 @@ bn_mp_mul_2d.o: $(TOMMATH_DIR)/bn_mp_mul_2d.c bn_mp_mul_d.o: $(TOMMATH_DIR)/bn_mp_mul_d.c $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_mul_d.c +bn_mp_neg.o: $(TOMMATH_DIR)/bn_mp_neg.c + $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_neg.c + +bn_mp_or.o: $(TOMMATH_DIR)/bn_mp_or.c + $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_or.c + bn_mp_radix_size.o: $(TOMMATH_DIR)/bn_mp_radix_size.c $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_radix_size.c @@ -1293,15 +1323,27 @@ bn_mp_rshd.o: $(TOMMATH_DIR)/bn_mp_rshd.c bn_mp_set.o: $(TOMMATH_DIR)/bn_mp_set.c $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_set.c +bn_mp_shrink.o: $(TOMMATH_DIR)/bn_mp_shrink.c + $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_shrink.c + bn_mp_sqr.o: $(TOMMATH_DIR)/bn_mp_sqr.c $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_sqr.c +bn_mp_sqrt.o: $(TOMMATH_DIR)/bn_mp_sqrt.c + $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_sqrt.c + bn_mp_sub.o: $(TOMMATH_DIR)/bn_mp_sub.c $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_sub.c bn_mp_sub_d.o: $(TOMMATH_DIR)/bn_mp_sub_d.c $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_sub_d.c +bn_mp_to_unsigned_bin.o: $(TOMMATH_DIR)/bn_mp_to_unsigned_bin.c + $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_to_unsigned_bin.c + +bn_mp_to_unsigned_bin_n.o: $(TOMMATH_DIR)/bn_mp_to_unsigned_bin_n.c + $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_to_unsigned_bin_n.c + bn_mp_toom_mul.o: $(TOMMATH_DIR)/bn_mp_toom_mul.c $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_toom_mul.c @@ -1311,6 +1353,12 @@ bn_mp_toom_sqr.o: $(TOMMATH_DIR)/bn_mp_toom_sqr.c bn_mp_toradix_n.o: $(TOMMATH_DIR)/bn_mp_toradix_n.c $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_toradix_n.c +bn_mp_unsigned_bin_size.o: $(TOMMATH_DIR)/bn_mp_unsigned_bin_size.c + $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_unsigned_bin_size.c + +bn_mp_xor.o: $(TOMMATH_DIR)/bn_mp_xor.c + $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_xor.c + bn_mp_zero.o: $(TOMMATH_DIR)/bn_mp_zero.c $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_zero.c diff --git a/win/Makefile.in b/win/Makefile.in index 7a0e7ce..3a5cefc 100644 --- a/win/Makefile.in +++ b/win/Makefile.in @@ -5,7 +5,7 @@ # "autoconf" program (constructs like "@foo@" will get replaced in the # actual Makefile. # -# RCS: @(#) $Id: Makefile.in,v 1.91 2005/08/24 17:56:24 andreas_kupries Exp $ +# RCS: @(#) $Id: Makefile.in,v 1.92 2005/10/08 14:42:54 dgp Exp $ VERSION = @TCL_VERSION@ @@ -188,7 +188,7 @@ RM = rm -f COPY = cp CC_SWITCHES = ${CFLAGS} ${CFLAGS_WARNING} ${TCL_SHLIB_CFLAGS} \ --I"${GENERIC_DIR_NATIVE}" -DTCL_TOMMATH -I"${TOMMATH_DIR_NATIVE}" \ +-I"${GENERIC_DIR_NATIVE}" -DTCL_TOMMATH -DMP_PREC=4 -I"${TOMMATH_DIR_NATIVE}" \ -I"${WIN_DIR_NATIVE}" ${AC_FLAGS} \ ${COMPILE_DEBUG_FLAGS} @@ -196,7 +196,7 @@ CC_OBJNAME = @CC_OBJNAME@ CC_EXENAME = @CC_EXENAME@ STUB_CC_SWITCHES = ${CFLAGS} ${CFLAGS_WARNING} ${SHLIB_CFLAGS} \ --I"${GENERIC_DIR_NATIVE}" -DTCL_TOMMATH -I"${TOMMATH_DIR_NATIVE}" \ +-I"${GENERIC_DIR_NATIVE}" -DTCL_TOMMATH -DMP_PREC=4 -I"${TOMMATH_DIR_NATIVE}" \ -I"${WIN_DIR_NATIVE}" ${AC_FLAGS} \ ${COMPILE_DEBUG_FLAGS} @@ -289,10 +289,12 @@ TOMMATH_OBJS = \ bn_fast_s_mp_sqr.${OBJEXT} \ bn_mp_add.${OBJEXT} \ bn_mp_add_d.${OBJEXT} \ + bn_mp_and.${OBJEXT} \ bn_mp_clamp.${OBJEXT} \ bn_mp_clear.${OBJEXT} \ bn_mp_clear_multi.${OBJEXT} \ bn_mp_cmp.${OBJEXT} \ + bn_mp_cmp_d.${OBJEXT} \ bn_mp_cmp_mag.${OBJEXT} \ bn_mp_copy.${OBJEXT} \ bn_mp_count_bits.${OBJEXT} \ @@ -302,6 +304,7 @@ TOMMATH_OBJS = \ bn_mp_div_2d.${OBJEXT} \ bn_mp_div_3.${OBJEXT} \ bn_mp_exch.${OBJEXT} \ + bn_mp_expt_d.${OBJEXT} \ bn_mp_grow.${OBJEXT} \ bn_mp_init.${OBJEXT} \ bn_mp_init_copy.${OBJEXT} \ @@ -317,17 +320,25 @@ TOMMATH_OBJS = \ bn_mp_mul_2.${OBJEXT} \ bn_mp_mul_2d.${OBJEXT} \ bn_mp_mul_d.${OBJEXT} \ + bn_mp_neg.${OBJEXT} \ + bn_mp_or.${OBJEXT} \ bn_mp_radix_size.${OBJEXT} \ bn_mp_radix_smap.${OBJEXT} \ bn_mp_read_radix.${OBJEXT} \ bn_mp_rshd.${OBJEXT} \ bn_mp_set.${OBJEXT} \ + bn_mp_shrink.${OBJEXT} \ bn_mp_sqr.${OBJEXT} \ + bn_mp_sqrt.${OBJEXT} \ bn_mp_sub.${OBJEXT} \ bn_mp_sub_d.${OBJEXT} \ + bn_mp_to_unsigned_bin.${OBJEXT} \ + bn_mp_to_unsigned_bin_n.${OBJEXT} \ bn_mp_toom_mul.${OBJEXT} \ bn_mp_toom_sqr.${OBJEXT} \ bn_mp_toradix_n.${OBJEXT} \ + bn_mp_unsigned_bin_size.${OBJEXT} \ + bn_mp_xor.${OBJEXT} \ bn_mp_zero.${OBJEXT} \ bn_s_mp_add.${OBJEXT} \ bn_s_mp_mul_digs.${OBJEXT} \ diff --git a/win/makefile.vc b/win/makefile.vc index 3ced0df..da38877 100644 --- a/win/makefile.vc +++ b/win/makefile.vc @@ -12,7 +12,7 @@ # Copyright (c) 2001-2004 David Gravereaux. # #------------------------------------------------------------------------------ -# RCS: @(#) $Id: makefile.vc,v 1.139 2005/08/24 17:56:24 andreas_kupries Exp $ +# RCS: @(#) $Id: makefile.vc,v 1.140 2005/10/08 14:42:54 dgp Exp $ #------------------------------------------------------------------------------ # Check to see we are configured to build with MSVC (MSDEVDIR or MSVCDIR) @@ -341,10 +341,12 @@ TCLOBJS = \ $(TMP_DIR)\bn_fast_s_mp_sqr.obj \ $(TMP_DIR)\bn_mp_add.obj \ $(TMP_DIR)\bn_mp_add_d.obj \ + $(TMP_DIR)\bn_mp_and.obj \ $(TMP_DIR)\bn_mp_clamp.obj \ $(TMP_DIR)\bn_mp_clear.obj \ $(TMP_DIR)\bn_mp_clear_multi.obj \ $(TMP_DIR)\bn_mp_cmp.obj \ + $(TMP_DIR)\bn_mp_cmp_d.obj \ $(TMP_DIR)\bn_mp_cmp_mag.obj \ $(TMP_DIR)\bn_mp_copy.obj \ $(TMP_DIR)\bn_mp_count_bits.obj \ @@ -354,6 +356,7 @@ TCLOBJS = \ $(TMP_DIR)\bn_mp_div_2d.obj \ $(TMP_DIR)\bn_mp_div_3.obj \ $(TMP_DIR)\bn_mp_exch.obj \ + $(TMP_DIR)\bn_mp_expt_d.obj \ $(TMP_DIR)\bn_mp_grow.obj \ $(TMP_DIR)\bn_mp_init.obj \ $(TMP_DIR)\bn_mp_init_copy.obj \ @@ -369,17 +372,25 @@ TCLOBJS = \ $(TMP_DIR)\bn_mp_mul_2.obj \ $(TMP_DIR)\bn_mp_mul_2d.obj \ $(TMP_DIR)\bn_mp_mul_d.obj \ + $(TMP_DIR)\bn_mp_neg.obj \ + $(TMP_DIR)\bn_mp_or.obj \ $(TMP_DIR)\bn_mp_radix_size.obj \ $(TMP_DIR)\bn_mp_radix_smap.obj \ $(TMP_DIR)\bn_mp_read_radix.obj \ $(TMP_DIR)\bn_mp_rshd.obj \ $(TMP_DIR)\bn_mp_set.obj \ + $(TMP_DIR)\bn_mp_shrink.obj \ $(TMP_DIR)\bn_mp_sqr.obj \ + $(TMP_DIR)\bn_mp_sqrt.obj \ $(TMP_DIR)\bn_mp_sub.obj \ $(TMP_DIR)\bn_mp_sub_d.obj \ + $(TMP_DIR)\bn_mp_to_unsigned_bin.obj \ + $(TMP_DIR)\bn_mp_to_unsigned_bin_n.obj \ $(TMP_DIR)\bn_mp_toom_mul.obj \ $(TMP_DIR)\bn_mp_toom_sqr.obj \ $(TMP_DIR)\bn_mp_toradix_n.obj \ + $(TMP_DIR)\bn_mp_unsigned_bin_size.obj \ + $(TMP_DIR)\bn_mp_xor.obj \ $(TMP_DIR)\bn_mp_zero.obj \ $(TMP_DIR)\bn_s_mp_add.obj \ $(TMP_DIR)\bn_s_mp_mul_digs.obj \ @@ -452,7 +463,8 @@ crt = -MT TCL_INCLUDES = -I"$(WINDIR)" -I"$(GENERICDIR)" -I"$(TOMMATHDIR)" BASE_CFLAGS = $(cflags) $(cdebug) $(crt) $(TCL_INCLUDES) \ - -DTCL_PIPE_DLL=\"$(TCLPIPEDLLNAME)\" -DTCL_TOMMATH + -DTCL_PIPE_DLL=\"$(TCLPIPEDLLNAME)\" -DTCL_TOMMATH \ + -DMP_PREC=4 CON_CFLAGS = $(cflags) $(cdebug) $(crt) -DCONSOLE TCL_CFLAGS = $(BASE_CFLAGS) $(OPTDEFINES) STUB_CFLAGS = $(cflags) $(cdebug) $(OPTDEFINES) |